Bruno Crotman
13/10/2019
…da maldição do erro operacional
Fonte: (QLD 2016)
PS.: ele não é Nobel…
…e ainda…
Fonte: (Boddy 2016)
Meta final: que vários dos processos de análise de dados da empresa passem a ser feitos dentro do fluxo de trabalho do R.
Fonte:(Frigaard 2017)
Ao fim do curso o objetivo é que todos os fios da meada sejam puxados para que o aluno consiga continuar por si só usando a vasta documentação disponível.
Também amo o Excel, mas amo mais as seguintes vantagens:
Reprodutibilidade. Muito mais fácil refazer uma análise com código do que point and click
Menor risco operacional. A automatização é maior, a chance de erro na execução de um passo manual é nula
Menor risco de continuidade caso haja imprevistos com a equipe.
Maior flexibilidade. Virtualmente tudo é possível
Manutenção mais fácil
Controle de versão de forma profissional
Mais fácil do que parece
Ela é feita para lidar com dados
Comunidade de usuários gigante e cooperativa
Ferramentas poderosas para comunicação dos resultados, em documentos ou aplicações
Muitos pesquisadores em métodos quantitativos que estão no estado-da-arte publicam seus métodos em bibliotecas escritas em R
Prazeroso programar (Tidyverse, Shiny, R Markdown…)
Fonte:(Wickham and Grolemund 2016)
Fonte: (Frigaard 2017)
É muito comum possuirmos dados gerados em planilhas ou em algum suporte de formato estruturado ou semi-estruturado.
Estes dados podem ser organizados de forma “tidy” para análise
Após a possível execução de modelos, podemos publicar os resultados.
Impacto da temperatura no consumo de energia elétrica
R é uma linguagem que é interpretada por um engine gratuito.
RStudio é o melhor ambiente de programação da linguagem R. A versão mais simples, que é totalmente funcional, é gratuita.
Na visualização padrão, ele oferece um console para execução de comandos e uma janela com a visualização dos environments, ou seja, das variáveis que ele guarda na sessão atual.
No console é possível executar comandos, como o que atribui valor a uma variável
Note que a atribuição é feita com <- e não com = como na maioria das linguagens.
Dica: o atalho alt + - gera o sinal de atribuição
Os comandos que não atribuem valor a uma variável são ecoados na tela
## [1] 3
Veja o [1] no console. O R considera que tudo é um vetor. É uma linguagem muito baseada em operações vetoriais. Isso facilita muito as coisas quando se lida com dados.
O console serve só para testes, aprendizado de novos comandos, debug, experiências etc.
Para as atividades mais comuns de análise de dados, e para que elas sejam reprodutíveis, é necessária a criação de scripts.
Eles são salvos em um arquivo de extensão “.r”
Atalhos de teclado: ctrl+enter (rodar linhas selecionadas), ctrl+shift+enter (rodar script), ctrl+1 (foco no script), ctrl+2 ** (foco no console), ctrl+shift+F10 ** (reiniciar R), ctrl+shift+C (comentar/descomentar bloco) …
Refactoring
Document outline
Pane: Files/Plots/Packages/Help/Viewer
Pane: Environment/History/Connections/Git
Jobs
Controle de versão integrado com o Github
Cheat sheets
Todo o material do curso está hospedado no Github, inclusive esta apresentação, escrita em RMarkdown.
Os exemplos de código, as imagens e os dados mostrados nesta apresentação estão inclusos no repositório do curso.
O repositório fica em github/crotman/cursoR.
Para baixar este repositório no RStudio, crie um projeto em File/New Project, do tipo Github e use o endereço do repositório: https://github.com/crotman/CursoR.git.
Todo material é disponibilizado sob a licença Creative Commons Attribution-NonCommercial-ShareAlike 4.0 International License
Para o R, simplificando para o escopo deste curso, as variáveis “armazenam” os seguintes tipos:
## [1] 1 2 3 4 5 6 7 8 9 10
## [[1]]
## [1] "oi"
##
## [[2]]
## [1] 1
## # A tibble: 10 x 2
## col1 col2
## <int> <int>
## 1 1 11
## 2 2 12
## 3 3 13
## 4 4 14
## 5 5 15
## 6 6 16
## 7 7 17
## 8 8 18
## 9 9 19
## 10 10 20
## [1] 3
## [1] "sou o b"
Existe orientação a objetos no R, mas não está no escopo deste curso
Note que não há variáveis que armazenam dado escalar, como já vimos.
Dentre os vetores há:
vetores atômicos (seus elementos são do mesmo tipo primário)
listas (seus elementos, que são vetores atômicos, são de tipos primários diferentes)
Tipos de vetores
Fonte: (Wickham 2019)
Os vetores atômicos podem ser dos seguintes tipos:
Tipos primários
Fonte: (Wickham 2019)
## [1] FALSE
## [1] "integer"
## [1] "double"
## [1] 0.1
## [1] 1500
## [1] Inf
Uma das funções mais usadas do R é c(), que cria um vetor novo vetor combinando vetores.
## [1] 1 2 3
## [1] 1 2 3 4 5 6
## [1] 1.4 2.4 3.4 4.4 5.4 6.4 7.4 8.4 9.4
O operador : é usado para gerar um vetor com todos números que estão entre os operandos e são formados somando números inteiros ao primeiro operando.
## [1] 1 2 3 4 5 6 7 8 9 10
## [1] 1.5 2.5 3.5 4.5 5.5 6.5 7.5 8.5
A função seq() é usada para criar um vetor de várias formas.
Numa das formas especifica-se o valor inicial, o valor final e o incremento entre elementos do vetor.
## [1] 1.0 1.1 1.2 1.3 1.4 1.5 1.6 1.7 1.8 1.9 2.0 2.1 2.2 2.3 2.4 2.5 2.6
## [18] 2.7 2.8 2.9 3.0 3.1 3.2 3.3 3.4 3.5 3.6 3.7 3.8 3.9 4.0 4.1 4.2 4.3
## [35] 4.4 4.5 4.6 4.7 4.8 4.9 5.0 5.1 5.2 5.3 5.4 5.5 5.6 5.7 5.8 5.9 6.0
## [52] 6.1 6.2 6.3 6.4 6.5 6.6 6.7 6.8 6.9 7.0 7.1 7.2 7.3 7.4 7.5 7.6 7.7
## [69] 7.8 7.9 8.0 8.1 8.2 8.3 8.4 8.5 8.6 8.7 8.8 8.9 9.0 9.1 9.2 9.3 9.4
## [86] 9.5 9.6 9.7 9.8 9.9
Note que chamamos a função passando os parâmetros sem especificação de quais são eles. Eles são recebidos pela função dem específica.
Mas no R também é possível passar parâmetros de forma nomeada.
Clique em F1 enquanto tem o cursor em cima da função e veja a ordem dos parâmetros. Veja que outros parâmetros que não utilizamos. Podemos usar length.out ao invés de by:
## [1] 1 2 3 4 5 6 7 8 9 10
## [1] 1.00 3.25 5.50 7.75 10.00
Outro parâmetro, along.with, deixa que criemos um vetor num intervalo determinado e o mesmo número de elementos do vetor passado por este parâmetro.
## [1] 20.00000 28.88889 37.77778 46.66667 55.55556 64.44444 73.33333
## [8] 82.22222 91.11111 100.00000
Valores faltantes ou desconecidos são representados por NA
## [1] 1 NA
O valor NA quase sempre contamina os cálculos
## [1] NA
mas…
## [1] 1
A exceção são expressões que dão sempre o mesmo resultado independentemente do valor da variável
## [1] 1
## [1] TRUE
## [1] FALSE
A melhor forma de testar se existe um valor NA é is.na
## [1] FALSE TRUE FALSE
As operações do R são vetoriais. Numa operação entre um vetor e um escalar, a operação com o escalar é aplicada a cada elemento do vetor
## [1] 2 4 6 8 10
## [1] 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0
Numa operação com vetores do mesmo tamanho, os elementos são pareados
## [1] 1 4 9 16 25 36 49 64 81 100
Outro conceito importante é o de recycling.
Numa operação entre dois vetores de tamanhos diferentes, o vetor menor é repetido ciclicamente de forma a ficar com o mesmo tamanho do vetor maior.
Lembra que toda variável no R é um vetor?
Então… o escalar mostrado no primeiro código do slide anterior é um vetor de 1 elemento que sofre recycling
## [1] 1 4 3 8 5 12 7 16 9 20
Existem estruturas mais complexas na linguagem construídas a partir de vetores e listas.
Data Frame
Matrix
Array
Factor
Estruturas que representam datas
Objetos (no paradigma de orientação a objetos)
Vamos passar pelo Data Frame agora. Depois por Factor e objetos que representam Datas
Data Frames, e seu primo Tibble, são estruturas muito usadas em análises de dados feitas em R.
O data frame consiste em um conjunto de vetores nomeados, com o mesmo número de elementos, que formam uma estrutura retangular, onde cada coluna é um vetor e cada linha n contém o n-ésimo elemento dos vetores.
É similar, em muitas características, a uma tabela de banco de dados.
Essa estrutura é chave no paradigma “Tidy” que usaremos com as bibliotecas Tidyverse
Tibble é uma adaptação do Data Frame para análise de dados. Discutir essas diferenças está fora do escopo do curso. Algumas diferenças serão citadas o longo do material e justificam o uso do Tibble.
df <-
data.frame(
nome = c("João", "Maria", "Zezinho", "Juquinha"),
idade = c(7, 8, 9, 10),
altura = c(10, 11)
)
df## nome idade altura
## 1 João 7 10
## 2 Maria 8 11
## 3 Zezinho 9 10
## 4 Juquinha 10 11
#tibble não aceita recycling em vetores de tamanho diferente de 1
tib <-
#try evita que o erro paralise toda a execução do script
try(
tibble(
nome = c("João", "Maria", "Zezinho", "Juquinha"),
idade = c(7, 8, 9, 10),
altura = c(10, 11)
)
)## Error : Tibble columns must have consistent lengths, only values of length one are recycled:
## * Length 2: Column `altura`
## * Length 4: Columns `nome`, `idade`
## Backtrace:
## x
## 1. +-rmarkdown::render("C:/Temp/CursoR/Conteudo.Rmd", encoding = "UTF-8")
## 2. | \-knitr::knit(...)
## 3. | \-knitr:::process_file(text, output)
## 4. | +-base::withCallingHandlers(...)
## 5. | +-knitr:::process_group(group)
## 6. | \-knitr:::process_group.block(group)
## 7. | \-knitr:::call_block(x)
## 8. | \-knitr:::block_exec(params)
## 9. | +-knitr:::in_dir(...)
## 10. | \-knitr:::evaluate(...)
## 11. | \-evaluate::evaluate(...)
## 12. | \-evaluate:::evaluate_call(...)
## 13. | +-evaluate:::timing_fn(...)
## 14. | +-base:::handle(...)
## 15. | +-base::withCallingHandlers(...)
## 16. | +-base::withVisible(eval(expr, envir, enclos))
## 17. | \-base::eval(expr, envir, enclos)
## 18. | \-base::eval(expr, envir, enclos)
## 19. +-base::try(...)
## 20. | \-base::tryCatch(...)
## 21. | \-base:::tryCatchList(expr, classes, parentenv, handlers)
## 22. | \-base:::tryCatchOne(expr, names, parentenv, handlers[[1L]])
## 23. | \-base:::doTryCatch(return(expr), name, parentenv, handler)
## 24. \-tibble::tibble(...)
## 25. \-tibble:::lst_to_tibble(xlq$output, .rows, .name_repair, lengths = xlq$lengths)
## 26. \-tibble:::recycle_columns(x, .rows, lengths)
A linguagem oferece comandos de controle de fluxo similares aos de outras linguagens.
Podemos dividir os comandos de controle de fluxo em dois tipos:
choices: execução alternativa de comandos
loops: execução repetida de comandos
if, ifelseO comando if funciona para um valor lógico escalar
## [1] "2 mais 2 são 4"
Note o operador de comparação == e não =
A função if_else (da biblioteca dplyr) funciona de vetorial. if_else é mais rápida que a função ifelse da biblioteca base, mas só aceita argumentos de mesmo tipo no segundo e terceiro parâmetros
jogo_do_pim_silvio_santos <- if_else(
condition = 1:40 %% 4 == 0 ,
true = "PIM",
false = as.character(1:40)
)
jogo_do_pim_silvio_santos## [1] "1" "2" "3" "PIM" "5" "6" "7" "PIM" "9" "10" "11"
## [12] "PIM" "13" "14" "15" "PIM" "17" "18" "19" "PIM" "21" "22"
## [23] "23" "PIM" "25" "26" "27" "PIM" "29" "30" "31" "PIM" "33"
## [34] "34" "35" "PIM" "37" "38" "39" "PIM"
Note o operador %% e a função de coerção de tipo as.character
switch e case_whenA cláusula switch e a função dplyr::case_when evitam que o programador tenha que criar muitos if else aninhados
## [1] "começa com b"
Note que a condição vai sendo testada na ordem e stop gera um erro
case_when serve ao caso vetorial
## [1] "1" "par" "3" "par" "5" "par" "7"
## [8] "par" "9" "dezena" "11" "par" "13" "par"
## [15] "15" "par" "17" "par" "19" "dezena" "21"
## [22] "par" "23" "par" "25" "par" "27" "par"
## [29] "29" "dezena" "31" "par" "33" "par" "35"
## [36] "par" "37" "par" "39" "dezena"
A cláusula de loop mais usada e mais versátil é for
## [1] 1
## [1] 4
## [1] 9
## [1] 16
## [1] 25
As cláusulas next e break modificam o comportamento, respectivamente caminhando direto para a próxima iteração e saindo do for
## [1] 1
## [1] 3
## [1] 5
## [1] 1
Vamos ver que quase sempre é desnecessário usar loop para as tarefas que vamos executar.
O caráter vetorial da linguagem, aliado a funcionalidades das bibliotecas, faz com que a grande maioria dos loops sejam desnecessários.
O código fica mais limpo e expressivo e mais rápido. Às vezes MUITO mais rápido. Isso ocorre por motivos além do escopo do curso (alocação de memória, código interpretado x código compilado em C++ etc.)
O código abaixo usa loop e programação funcional, respectivamente. Programação funcional será abordada posteriormente no material.
com_loop <- function(n){
x <- integer()
for (i in 1:n){
x <- c(x, i^2)
}
x
}
#programação funcional: aprenderemos posteriomente
sem_loop <- function(n){
x <- 1:n %>%
map_dbl(function(x){x^2})
x
}Abaixo as três formas de fazer a mesma conta que terão a performance avaliada
## [1] 1 4 9 16 25
## [1] 1 4 9 16 25
## [1] 1 4 9 16 25
A biblioteca bench oferece funções ótimas para avaliar a performance de pedaços pequenos de código.
resultados_perf <- mark(
sem_loop(1e4),
com_loop(1e4),
(1:1e4)^2
)
#aprenderemos o que é %>% e select() posteriormente
resultados_perf %>%
select(expression, min, median, `itr/sec` )## # A tibble: 3 x 4
## expression min median `itr/sec`
## <bch:expr> <bch:tm> <bch:tm> <dbl>
## 1 sem_loop(10000) 7.01ms 8.4ms 73.3
## 2 com_loop(10000) 132.15ms 133.1ms 7.49
## 3 (1:10000)^2 17.73us 19.8us 20356.
Qual o valor de v1 ?
Qual o valor de v2
Complete a lacuna:
Qual o valor de x ?
Complete a lacuna para imprimir os quadrados dos números de 1 a 10
Monty Hall era uma espécie de Sílvio Santos juvenil (sub 80) americano.
Um dos seus jogos consistia em mostrar três portas ao otár… (ops) convidado. Em uma delas tem um carro.
Antes do resultado, o apresentador revela uma das portas e pergunta se o convidado que trocar a escolha.
O que vocês acham? Melhor trocar, manter a escolha original ou tanto faz?
Note o que há de interessante no código (comentado)
set.seed(88)
joga_monty_hall <- function(troca){
portas <- 1:3
#sample() sorteia elementos com ou sem reposição
porta_carro <- sample(portas, size = 1, replace = FALSE)
primeira_escolha <- 1
#Seleção negativa (retirando elementos)
portas_pra_revelar <- portas[-c(porta_carro, primeira_escolha)]
porta_revelada <- sample( c(portas_pra_revelar, portas_pra_revelar ), 1)
if(troca){
escolha <- portas[-c(primeira_escolha, porta_revelada)]
}
else{
escolha <- primeira_escolha
}
escolha == porta_carro
}
n <- 1000
#replicate executa múltiplas vezes um comando e armazena os resultados em uma estruturaúnica
troca <- replicate(n = n, joga_monty_hall(troca = TRUE))
fica <- replicate(n = n, joga_monty_hall(troca = FALSE))Resultados:
## [1] 0.675
## [1] 0.323
Vamos ver… mas dá pra simular sem saber quase nada.
Vamos usar uma das funções da família r<familia de distribuição de prob>(). Neste caso, a rbinom, que simula a distribução binomial (aquela que equivale ao evento de jogar n moedas (ou alguma coisa com dois lados) para cima e ver quantas deram cara).
n_simul <- 10000
n_questoes <- 240
min_aprovacao <- 0.6
n_aprovado <- 240 * min_aprovacao
prob_questao <- 0.2
acertos <- rbinom(n = n_simul, size = n_questoes, prob = prob_questao )
sum(acertos >= n_aprovado)/n_simul ## [1] 0
A chance é praticamente nula.
Na verdade, a grande massa da distribuição fica muito distante.
dado <- enframe(acertos/n_questoes)
mostra_chances <- function(acertos, n_questoes){
ggplot(enframe(acertos/n_questoes)) +
geom_density( aes(x = value)) +
scale_x_continuous(
labels = percent_format(accuracy = 1),
limits = c(0,1),
breaks = seq(0, 1, 0.1)
) +
labs(x ="% Acertos") +
geom_vline(xintercept = min_aprovacao, color = "red") +
theme_light()
}
mostra_chances(acertos, n_questoes)O exemplo anterior era muito simplista: ninguém chuta tudo.
Imagine que sabemos qual a chance de aparecer uma pergunta onde podemos descartar 0 alternativas, a chance de uma onde descartamos 1 e assim por diante.
#definindo a chance podermos eliminar 0, 1, 2, ... 4 alternativas
fracao_eliminar_questoes <- c( 0.1, 0.1, 0.2, 0.25 , 0.35 )
#definindo o número de questões
n_questoes_cada_elimina <- t(rmultinom(n_simul, size = n_questoes, fracao_eliminar_questoes))
probs_quando_elimina <- 1/(5:1)
acertos_concatenados <-
rbinom(
n = n_simul * 5 ,
size = as.vector(t(n_questoes_cada_elimina)),
prob = probs_quando_elimina
)## [,1] [,2] [,3] [,4] [,5]
## [1,] 23 24 50 47 96
## [2,] 24 17 48 64 87
## [3,] 23 30 43 56 88
## [4,] 20 25 51 52 92
## [1] 4 6 17 25 96 4 3 13 34 87 6 5 13 36 88 4 9 17 25 92
## [,1] [,2] [,3] [,4] [,5]
## [1,] 4 6 17 25 96
## [2,] 4 3 13 34 87
## [3,] 6 5 13 36 88
## [4,] 4 9 17 25 92
## [5,] 6 5 11 30 92
## [1] 0.3131
Dentro de todo o hype envolvendo Data Science, surgem as buzz words mais mirabolantes: machine learning, AI, Deep Learning…
Tudo isso é legal, mas a habilidade de preparar os dados para os modelos, preparar os hiperparâmetros e especificações alternativas ainda melhora muito a análise. Anote mais uma buzz word: FEATURE ENGINEERING
A agilidade de se tentar abordagens alterativas com os dados cresce muito quando dominamos a arte de manipular os data frames. Por isso o peso grande dado neste curso.
Arrumar os dados de forma que as linhas sejam eventos e as colunas sejam atributos do evento ajuda muito a rodar modelos e construir visualizações eficientemente.
O que é o evento e o que é o atributo pode variar até para diferentes usos do mesmo dado. Mas a prática ajuda a determinar isso.
%>%)Normalmente os tratamentos de dados são feitos em múltiplos passos encadeados:
## # A tibble: 6 x 6
## country continent year lifeExp pop gdpPercap
## <fct> <fct> <int> <dbl> <int> <dbl>
## 1 Afghanistan Asia 1952 28.8 8425333 779.
## 2 Afghanistan Asia 1957 30.3 9240934 821.
## 3 Afghanistan Asia 1962 32.0 10267083 853.
## 4 Afghanistan Asia 1967 34.0 11537966 836.
## 5 Afghanistan Asia 1972 36.1 13079460 740.
## 6 Afghanistan Asia 1977 38.4 14880372 786.
Vamos imaginar que queremos a média de PIB per capita por continente em 2007.
Note quanto código desnecessário há nestas linhas: variáveis que não precisavam ser nomeadas nem passadas explicitamente como parâmetro.
Este código desnecessário causa fadiga no programador e confunde o próprio programador e o leitor posterior do código.
#vamos cobrir essas funções de tratamento posteriormente
gapminder_07 <- filter(gapminder, year == 2007)
gapminder_07_group_continente <- group_by(gapminder_07, continent)
gapminder_media_gdp_continente <- summarise(
gapminder_07_group_continente, media_gdp = sum(gdpPercap * pop)/sum(pop)
)
resultado <- arrange(gapminder_media_gdp_continente, desc(media_gdp))
resultado## # A tibble: 5 x 2
## continent media_gdp
## <fct> <dbl>
## 1 Oceania 32885.
## 2 Europe 25244.
## 3 Americas 21603.
## 4 Asia 5432.
## 5 Africa 2561.
%>%) (cont.)O operador pipe %>% faz o seguinte:
x %>% y(z) = y(x,z)
Ou seja, o primeiro operando é enfiado como primeiro parâmetro da função que está no segundo operando.
Isso faz com que possamos escrever o código anterior assim:
resultado <- gapminder %>%
filter(year == 2007) %>%
group_by(continent) %>%
summarise(
media_gdp = sum(gdpPercap * pop) / sum(pop)
) %>%
arrange(desc(media_gdp))
resultado## # A tibble: 5 x 2
## continent media_gdp
## <fct> <dbl>
## 1 Oceania 32885.
## 2 Europe 25244.
## 3 Americas 21603.
## 4 Asia 5432.
## 5 Africa 2561.
Note que agora podemos interpretar o código facilmente como uma série de comandos de tratamento em cima dos dados.
Não é por coincidência que as funções de tratamento das bibliotecas tidyverse que veremos adiante são verbos e recebem os dados como primeiro parâmetro.
Agora o mais importante de tudo: O ATALHO PARA O %>% É CTRL + SHIFT + M
dplyrFonte: (Courtiol 2019)
CRAN é o repositório de bibliotecas mantido pelo R com contribuição de populares.
Além de funcionalidades estatísticas e funcionalidades para lidar com dados, há dados e funcionalidades para buscar dados online.
Usaremos várias das bases como exemplo.
A primeira é a do Banco Mundial, muito rica para quem gosta de dados socioeconômicos
Para acessar um indicador precisamos achá-lo na base de indicadores com a função wbsearch()
#pattern é uma expressão regular. \\ serve para dizer que "(" é mesmo "("
#e não o ( usado nas operações de expressão regular (fora do escopo do curso)
indicadores <- wbsearch(pattern = "GINI index \\(World Bank estimate\\)")
indicadores## indicatorID indicator
## 1348 SI.POV.GINI GINI index (World Bank estimate)
Sabendo o ID do indicador, podemos consultá-lo com a função wb()
#mrv é most recent values. Pode ser usado para buscar os n valores mais recentes
gini = wb(indicator = "SI.POV.GINI", mrv= 10, POSIXct = TRUE)
head(gini)## iso3c date value indicatorID indicator iso2c
## 486 ALB 2012 29.0 SI.POV.GINI GINI index (World Bank estimate) AL
## 490 ALB 2008 30.0 SI.POV.GINI GINI index (World Bank estimate) AL
## 497 DZA 2011 27.6 SI.POV.GINI GINI index (World Bank estimate) DZ
## 530 AGO 2008 42.7 SI.POV.GINI GINI index (World Bank estimate) AO
## 541 ARG 2017 41.2 SI.POV.GINI GINI index (World Bank estimate) AR
## 542 ARG 2016 42.0 SI.POV.GINI GINI index (World Bank estimate) AR
## country date_ct granularity
## 486 Albania 2012-01-01 annual
## 490 Albania 2008-01-01 annual
## 497 Algeria 2011-01-01 annual
## 530 Angola 2008-01-01 annual
## 541 Argentina 2017-01-01 annual
## 542 Argentina 2016-01-01 annual
A função select() é usada para selecionar colunas do data frame/tibble
## Observations: 682
## Variables: 9
## $ iso3c <chr> "ALB", "ALB", "DZA", "AGO", "ARG", "ARG", "ARG", "...
## $ date <chr> "2012", "2008", "2011", "2008", "2017", "2016", "2...
## $ value <dbl> 29.0, 30.0, 27.6, 42.7, 41.2, 42.0, 41.7, 41.0, 41...
## $ indicatorID <chr> "SI.POV.GINI", "SI.POV.GINI", "SI.POV.GINI", "SI.P...
## $ indicator <chr> "GINI index (World Bank estimate)", "GINI index (W...
## $ iso2c <chr> "AL", "AL", "DZ", "AO", "AR", "AR", "AR", "AR", "A...
## $ country <chr> "Albania", "Albania", "Algeria", "Angola", "Argent...
## $ date_ct <date> 2012-01-01, 2008-01-01, 2011-01-01, 2008-01-01, 2...
## $ granularity <chr> "annual", "annual", "annual", "annual", "annual", ...
## country date value iso3c
## 486 Albania 2012 29.0 ALB
## 490 Albania 2008 30.0 ALB
## 497 Algeria 2011 27.6 DZA
## 530 Angola 2008 42.7 AGO
## 541 Argentina 2017 41.2 ARG
## 542 Argentina 2016 42.0 ARG
É possível usar a seleção negativa assim como fizemos com vetores
## country date value
## 486 Albania 2012 29.0
## 490 Albania 2008 30.0
## 497 Algeria 2011 27.6
## 530 Angola 2008 42.7
## 541 Argentina 2017 41.2
## 542 Argentina 2016 42.0
Algumas funções helpers nos ajudam a usar a função select e são muito úteis para tratamentos mais elaborados.
Pra mostrar mais funcionalidades da função select, vamos usar uma base com dados eleitorais brasileiros, que retorna mais colunas
## Processing the data...
## Done.
## Observations: 29,113
## Variables: 58
## $ DATA_GERACAO <chr> "14/10/2019", "14/10/2019", "14...
## $ HORA_GERACAO <time> 19:12:28, 19:12:28, 19:12:28, ...
## $ ANO_ELEICAO <dbl> 2018, 2018, 2018, 2018, 2018, 2...
## $ COD_TIPO_ELEICAO <dbl> 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2...
## $ NOME_TIPO_ELEICAO <chr> "ELEIÇÃO ORDINÁRIA", "ELEIÇÃO O...
## $ NUM_TURNO <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1...
## $ COD_ELEICAO <dbl> 297, 297, 297, 297, 297, 297, 2...
## $ DESCRICAO_ELEICAO <chr> "Eleições Gerais Estaduais 2018...
## $ DATA_ELEICAO <chr> "07/10/2018", "07/10/2018", "07...
## $ ABRANGENCIA <chr> "ESTADUAL", "ESTADUAL", "ESTADU...
## $ SIGLA_UF <chr> "AC", "AC", "AC", "AC", "AC", "...
## $ SIGLA_UE <chr> "AC", "AC", "AC", "AC", "AC", "...
## $ DESCRICAO_UE <chr> "ACRE", "ACRE", "ACRE", "ACRE",...
## $ CODIGO_CARGO <dbl> 7, 7, 7, 7, 6, 10, 7, 7, 7, 7, ...
## $ DESCRICAO_CARGO <chr> "DEPUTADO ESTADUAL", "DEPUTADO ...
## $ SEQUENCIAL_CANDIDATO <dbl> 10000600138, 10000601029, 10000...
## $ NUMERO_CANDIDATO <dbl> 44333, 14233, 51353, 17345, 159...
## $ NOME_CANDIDATO <chr> "APARECIDO OLIVEIRA SILVA", "FA...
## $ NOME_URNA_CANDIDATO <chr> "BUIU", "FABIANO OLIVEIRA", "RI...
## $ NOME_SOCIAL_CANDIDATO <chr> "#NULO#", "#NULO#", "#NULO#", "...
## $ CPF_CANDIDATO <chr> "03674195801", "88102629215", "...
## $ EMAIL_CANDIDATO <chr> "JK.AC@HOTMAIL.COM", "SUZANASBI...
## $ COD_SITUACAO_CANDIDATURA <dbl> 12, 12, 3, 12, 3, 12, 12, 12, 1...
## $ DES_SITUACAO_CANDIDATURA <chr> "APTO", "APTO", "INAPTO", "APTO...
## $ COD_DETALHE_SITUACAO_CAND <dbl> 2, 2, 14, 2, 14, 2, 2, 2, 2, 2,...
## $ DES_DETALHE_SITUACAO_CAND <chr> "DEFERIDO", "DEFERIDO", "INDEFE...
## $ TIPO_AGREMIACAO <chr> "COLIGAÇÃO", "PARTIDO ISOLADO",...
## $ NUMERO_PARTIDO <dbl> 44, 14, 51, 17, 15, 17, 12, 45,...
## $ SIGLA_PARTIDO <chr> "PRP", "PTB", "PATRI", "PSL", "...
## $ NOME_PARTIDO <chr> "PARTIDO REPUBLICANO PROGRESSIS...
## $ CODIGO_LEGENDA <dbl> 10000050007, 10000050036, 10000...
## $ NOME_COLIGACAO <chr> "FRENTE - PSOL, PV, PRP E PPL",...
## $ COMPOSICAO_LEGENDA <chr> "PSOL / PV / PRP / PPL", "PTB",...
## $ CODIGO_NACIONALIDADE <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1...
## $ DESCRICAO_NACIONALIDADE <chr> "BRASILEIRA NATA", "BRASILEIRA ...
## $ SIGLA_UF_NASCIMENTO <chr> "AC", "AC", "AC", "AC", "AC", "...
## $ CODIGO_MUNICIPIO_NASCIMENTO <dbl> -3, -3, -3, -3, -3, -3, -3, -3,...
## $ NOME_MUNICIPIO_NASCIMENTO <chr> "SENADOR GUIOMARD", "RIO BRANCO...
## $ DATA_NASCIMENTO <chr> "28/08/1962", "10/10/1985", "24...
## $ IDADE_DATA_POSSE <dbl> 56, 33, 43, 31, 49, 39, 57, 56,...
## $ NUM_TITULO_ELEITORAL_CANDIDATO <chr> "012575831864", "004783742437",...
## $ CODIGO_SEXO <dbl> 2, 2, 4, 2, 2, 4, 2, 2, 2, 2, 2...
## $ DESCRICAO_SEXO <chr> "MASCULINO", "MASCULINO", "FEMI...
## $ COD_GRAU_INSTRUCAO <dbl> 6, 6, 8, 7, 8, 8, 4, 4, 6, 8, 6...
## $ DESCRICAO_GRAU_INSTRUCAO <chr> "ENSINO MÉDIO COMPLETO", "ENSIN...
## $ CODIGO_ESTADO_CIVIL <dbl> 1, 3, 1, 3, 3, 3, 3, 3, 1, 3, 3...
## $ DESCRICAO_ESTADO_CIVIL <chr> "SOLTEIRO(A)", "CASADO(A)", "SO...
## $ CODIGO_COR_RACA <chr> "02", "03", "01", "03", "03", "...
## $ DESCRICAO_COR_RACA <chr> "PRETA", "PARDA", "BRANCA", "PA...
## $ CODIGO_OCUPACAO <dbl> 999, 999, 394, 999, 297, 303, 9...
## $ DESCRICAO_OCUPACAO <chr> "OUTROS", "OUTROS", "AUXILIAR D...
## $ DESPESA_MAX_CAMPANHA <dbl> 0, 0, -1, 0, -1, -1, 0, 0, 0, 0...
## $ COD_SIT_TOT_TURNO <dbl> 5, 5, -1, 5, 4, 4, 5, 5, 5, 5, ...
## $ DESC_SIT_TOT_TURNO <chr> "SUPLENTE", "SUPLENTE", "#NULO#...
## $ SITUACAO_REELEICAO <chr> "N", "N", "N", "N", "N", "N", "...
## $ SITUACAO_DECLARAR_BENS <chr> "N", "N", "N", "N", "S", "N", "...
## $ NUMERO_PROTOCOLO_CANDIDATURA <dbl> -1, -1, -1, -1, -1, -1, -1, -1,...
## $ NUMERO_PROCESSO <chr> "06001299020186010000", "060030...
candidatos_select <- candidatos %>%
select(ends_with("candidato"))
datatable(head(candidatos_select))A função helper num_range ajuda a encontrar colunas do tipo prefixo_n. Isso é muito comum em bases de dados
A biblioteca worldmet retorna dados de estações meteorológicas espalhadas pelo planeta
Primeiro é necessário encontrar o código da base desejada
A função abaixo retorna os dados de uma estação. Veja que alguns campos têm um sufixo _n
dados_heathrow <- importNOAA(code = "037720-99999", year = 2019,
precip = TRUE, PWC = FALSE, parallel = TRUE)
glimpse(dados_heathrow)## Observations: 6,862
## Variables: 26
## $ date <dttm> 2019-01-01 00:00:00, 2019-01-01 01:00:00, 2019-01...
## $ usaf <chr> "037720", "037720", "037720", "037720", "037720", ...
## $ wban <chr> "99999", "99999", "99999", "99999", "99999", "9999...
## $ code <chr> "037720-99999", "037720-99999", "037720-99999", "0...
## $ station <chr> "HEATHROW", "HEATHROW", "HEATHROW", "HEATHROW", "H...
## $ lat <dbl> 51.47967, 51.47967, 51.47967, 51.47967, 51.47967, ...
## $ lon <dbl> -0.4573333, -0.4573333, -0.4573333, -0.4573333, -0...
## $ elev <dbl> 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25...
## $ wd <dbl> 283.706052, 286.994553, 290.000000, 290.000000, 27...
## $ ws <dbl> 3.266667, 3.433333, 4.100000, 3.433333, 3.266667, ...
## $ ceil_hgt <dbl> 657.3333, 667.3333, 728.0000, 768.0000, 778.3333, ...
## $ visibility <dbl> 22000, 28000, 45000, 45000, 35000, 35000, 28000, 2...
## $ air_temp <dbl> 8.666667, 8.933333, 9.000000, 9.000000, 7.966667, ...
## $ dew_point <dbl> 4.9333333, 4.9666667, 4.7666667, 4.8000000, 4.8000...
## $ atmos_pres <dbl> 1034.8, 1034.5, 1034.6, 1034.5, 1034.4, 1033.9, 10...
## $ RH <dbl> 77.67802, 76.42835, 75.06237, 75.23079, 80.81974, ...
## $ cl_1 <dbl> 7.666667, 8.000000, 7.666667, 8.000000, 7.666667, ...
## $ cl_1_height <dbl> 657.3333, 667.3333, 728.0000, 768.0000, 778.3333, ...
## $ cl_2 <dbl> 8.000000, NA, 8.000000, NA, NA, NA, 7.000000, 7.00...
## $ cl_2_height <dbl> 792, NA, 914, NA, NA, NA, 1006, 1036, NA, 720, 121...
## $ cl_3 <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA...
## $ cl_3_height <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA...
## $ precip_12 <dbl> NA, NA, NA, NA, NA, NA, 0, NA, NA, NA, NA, NA, NA,...
## $ precip_6 <dbl> 0, NA, NA, NA, NA, NA, 0, NA, NA, NA, NA, NA, 0, N...
## $ cl <dbl> 8.000000, 8.000000, 8.000000, 8.000000, 7.666667, ...
## $ precip <dbl> NA, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0...
A função helper num_range ajuda a selecionar essas colunas com prefixo comum e um sufixo numérico
dados_heathrow_select <- dados_heathrow %>%
select(
date,
num_range("cl_", 1:3 ),
num_range("precip_", c(6, 12))
)
head(dados_heathrow_select)## # A tibble: 6 x 6
## date cl_1 cl_2 cl_3 precip_6 precip_12
## <dttm> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2019-01-01 00:00:00 7.67 8 NA 0 NA
## 2 2019-01-01 01:00:00 8 NA NA NA NA
## 3 2019-01-01 02:00:00 7.67 8 NA NA NA
## 4 2019-01-01 03:00:00 8 NA NA NA NA
## 5 2019-01-01 04:00:00 7.67 NA NA NA NA
## 6 2019-01-01 05:00:00 6 NA NA NA NA
Outra função útil é a everything, que ajuda, por exemplo, a passar algumas colunas para o início do tibble.
dados_heathrow_select <- dados_heathrow %>%
select(
date,
air_temp,
everything()
)
glimpse(dados_heathrow_select)## Observations: 6,862
## Variables: 26
## $ date <dttm> 2019-01-01 00:00:00, 2019-01-01 01:00:00, 2019-01...
## $ air_temp <dbl> 8.666667, 8.933333, 9.000000, 9.000000, 7.966667, ...
## $ usaf <chr> "037720", "037720", "037720", "037720", "037720", ...
## $ wban <chr> "99999", "99999", "99999", "99999", "99999", "9999...
## $ code <chr> "037720-99999", "037720-99999", "037720-99999", "0...
## $ station <chr> "HEATHROW", "HEATHROW", "HEATHROW", "HEATHROW", "H...
## $ lat <dbl> 51.47967, 51.47967, 51.47967, 51.47967, 51.47967, ...
## $ lon <dbl> -0.4573333, -0.4573333, -0.4573333, -0.4573333, -0...
## $ elev <dbl> 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25...
## $ wd <dbl> 283.706052, 286.994553, 290.000000, 290.000000, 27...
## $ ws <dbl> 3.266667, 3.433333, 4.100000, 3.433333, 3.266667, ...
## $ ceil_hgt <dbl> 657.3333, 667.3333, 728.0000, 768.0000, 778.3333, ...
## $ visibility <dbl> 22000, 28000, 45000, 45000, 35000, 35000, 28000, 2...
## $ dew_point <dbl> 4.9333333, 4.9666667, 4.7666667, 4.8000000, 4.8000...
## $ atmos_pres <dbl> 1034.8, 1034.5, 1034.6, 1034.5, 1034.4, 1033.9, 10...
## $ RH <dbl> 77.67802, 76.42835, 75.06237, 75.23079, 80.81974, ...
## $ cl_1 <dbl> 7.666667, 8.000000, 7.666667, 8.000000, 7.666667, ...
## $ cl_1_height <dbl> 657.3333, 667.3333, 728.0000, 768.0000, 778.3333, ...
## $ cl_2 <dbl> 8.000000, NA, 8.000000, NA, NA, NA, 7.000000, 7.00...
## $ cl_2_height <dbl> 792, NA, 914, NA, NA, NA, 1006, 1036, NA, 720, 121...
## $ cl_3 <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA...
## $ cl_3_height <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA...
## $ precip_12 <dbl> NA, NA, NA, NA, NA, NA, 0, NA, NA, NA, NA, NA, NA,...
## $ precip_6 <dbl> 0, NA, NA, NA, NA, NA, 0, NA, NA, NA, NA, NA, 0, N...
## $ cl <dbl> 8.000000, 8.000000, 8.000000, 8.000000, 7.666667, ...
## $ precip <dbl> NA, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0...
rename()rename() é usada para modificar os nomes das colunas. Ela renomeia as colunas indicadas e mantném as outras.
rename()## # A tibble: 6 x 26
## data usaf wban code estacao lat lon elev wd
## <dttm> <chr> <chr> <chr> <chr> <dbl> <dbl> <dbl> <dbl>
## 1 2019-01-01 00:00:00 0377~ 99999 0377~ HEATHR~ 51.5 -0.457 25 284.
## 2 2019-01-01 01:00:00 0377~ 99999 0377~ HEATHR~ 51.5 -0.457 25 287.
## 3 2019-01-01 02:00:00 0377~ 99999 0377~ HEATHR~ 51.5 -0.457 25 290
## 4 2019-01-01 03:00:00 0377~ 99999 0377~ HEATHR~ 51.5 -0.457 25 290
## 5 2019-01-01 04:00:00 0377~ 99999 0377~ HEATHR~ 51.5 -0.457 25 276.
## 6 2019-01-01 05:00:00 0377~ 99999 0377~ HEATHR~ 51.5 -0.457 25 267.
## # ... with 17 more variables: ws <dbl>, ceil_hgt <dbl>, visibility <dbl>,
## # temperatura <dbl>, dew_point <dbl>, atmos_pres <dbl>, RH <dbl>,
## # cl_1 <dbl>, cl_1_height <dbl>, cl_2 <dbl>, cl_2_height <dbl>,
## # cl_3 <dbl>, cl_3_height <dbl>, precip_12 <dbl>, precip_6 <dbl>,
## # cl <dbl>, precip <dbl>
rename() x select()select() também pode ser usado para renomear colunas, mas mantém apenas as colunas citadas
## # A tibble: 6 x 3
## data estacao temperatura
## <dttm> <chr> <dbl>
## 1 2019-01-01 00:00:00 HEATHROW 8.67
## 2 2019-01-01 01:00:00 HEATHROW 8.93
## 3 2019-01-01 02:00:00 HEATHROW 9
## 4 2019-01-01 03:00:00 HEATHROW 9
## 5 2019-01-01 04:00:00 HEATHROW 7.97
## 6 2019-01-01 05:00:00 HEATHROW 6.6
A função mutate é usada para criar novas colunas no tibble, mantendo as outras.
mutate()Notando que a coluna DATA_ELEICAO é um caracter, vamos criar uma coluna de tipo data.
## [1] "character"
O jeito mais fácil de fazer isso é usando uma das funções da biblioteca lubridate que veremos em detalhes em seguida
candidatos_com_data <- candidatos %>%
mutate(DATA_ELEICAO_TIPO_DATA = dmy(DATA_ELEICAO)) %>%
select(DATA_ELEICAO, DATA_ELEICAO_TIPO_DATA)
head(candidatos_com_data)## # A tibble: 6 x 2
## DATA_ELEICAO DATA_ELEICAO_TIPO_DATA
## <chr> <date>
## 1 07/10/2018 2018-10-07
## 2 07/10/2018 2018-10-07
## 3 07/10/2018 2018-10-07
## 4 07/10/2018 2018-10-07
## 5 07/10/2018 2018-10-07
## 6 07/10/2018 2018-10-07
É possível substituir um campo existente
candidatos_com_data <- candidatos %>%
mutate(DATA_ELEICAO = dmy(DATA_ELEICAO)) %>%
select(DATA_ELEICAO)
head(candidatos_com_data)## # A tibble: 6 x 1
## DATA_ELEICAO
## <date>
## 1 2018-10-07
## 2 2018-10-07
## 3 2018-10-07
## 4 2018-10-07
## 5 2018-10-07
## 6 2018-10-07
mutate()funções derivadas da mutate possibilitam a alteração de várias colunas ao mesmo tempo, usando os mesmos helpers que já vimos para a select e uma função à escolha
candidatos_com_data <- candidatos %>%
mutate_at(vars(starts_with("DATA_")), dmy ) %>%
select(starts_with("DATA_"))
head(candidatos_com_data)## # A tibble: 6 x 3
## DATA_GERACAO DATA_ELEICAO DATA_NASCIMENTO
## <date> <date> <date>
## 1 2019-10-14 2018-10-07 1962-08-28
## 2 2019-10-14 2018-10-07 1985-10-10
## 3 2019-10-14 2018-10-07 1975-02-24
## 4 2019-10-14 2018-10-07 1988-02-01
## 5 2019-10-14 2018-10-07 1970-01-28
## 6 2019-10-14 2018-10-07 1979-04-25
mutate() (cont.):Outras funções úteis são as que fazem operações acumuladas e as operações de lag() e lead()
## Registered S3 method overwritten by 'xts':
## method from
## as.zoo.xts zoo
## Registered S3 method overwritten by 'quantmod':
## method from
## as.zoo.data.frame zoo
## Registered S3 methods overwritten by 'forecast':
## method from
## fitted.fracdiff fracdiff
## residuals.fracdiff fracdiff
##
## BETS-package: Found 33 out of 18706 time series.
## # A tibble: 33 x 7
## code description unit periodicity start last_value source
## <chr> <chr> <chr> <chr> <chr> <chr> <chr>
## 1 1 Exchange rate - Free~ c.m.u~ D 28/11~ 26/03/2018 Sisbac~
## 2 10813 Exchange rate - Free~ c.m.u~ D 28/11~ 03/05/2018 Sisbac~
## 3 11753 Real effective excha~ Index M 31/01~ mar/2018 BCB-DS~
## 4 11758 Real effective excha~ Index M 31/01~ mar/2018 BCB-DS~
## 5 11763 Real effective excha~ Index M 31/01~ mar/2018 BCB-DS~
## 6 11768 Real effective excha~ Index M 31/01~ mar/2018 BCB-DS~
## 7 17887 Exchange rate (perio~ US$/c~ M 31/01~ nov/2016 IMF-IFS
## 8 17888 Exchange rate (perio~ US$/c~ M 31/01~ nov/2016 IMF-IFS
## 9 18441 Exchange rate (end o~ US$/c~ M 31/01~ nov/2016 IMF-IFS
## 10 18442 Exchange rate (end o~ US$/c~ M 31/01~ nov/2016 IMF-IFS
## # ... with 23 more rows
No código abaixo, calculamos o retorno da série, a volatilidade histórica e a volatilidade EWMA
## Registered S3 method overwritten by 'xts':
## method from
## as.zoo.xts zoo
## Registered S3 method overwritten by 'quantmod':
## method from
## as.zoo.data.frame zoo
## Registered S3 methods overwritten by 'forecast':
## method from
## fitted.fracdiff fracdiff
## residuals.fracdiff fracdiff
dolar_com_vol <- dolar %>%
filter(date > ymd("1994-07-01")) %>%
arrange(date) %>%
mutate(
retorno = (value - lag(value))/value,
retorno_quad = retorno^2,
dia = row_number(),
fator_ewma = (1/0.94)^dia*1e-20
) %>%
filter(!is.na(retorno)) %>%
mutate(vol = sqrt(cumvar(retorno)) * sqrt(252) ) %>%
mutate(vol_ewma = sqrt(cumsum(retorno_quad * fator_ewma)/cumsum(fator_ewma)) * sqrt(252) ) %>%
rename(dolar = value) %>%
select(
date,
dolar,
retorno,
vol,
vol_ewma
)
datatable(dolar_com_vol) %>%
formatPercentage(c("retorno", "vol", "vol_ewma"), 2)dolar_ajeitado <- dolar_com_vol %>%
gather(variavel, valor, - date)
dolar_ajeitado %>%
ggplot() +
geom_line(aes(x = date, y = valor)) +
facet_grid( variavel ~ . , scales = "free") +
theme_light() transmute():transmute() cria colunas e mantém apenas as colunas citadas
## # A tibble: 6 x 3
## ano pais pib
## <int> <fct> <dbl>
## 1 1952 Afghanistan 6567086330.
## 2 1957 Afghanistan 7585448670.
## 3 1962 Afghanistan 8758855797.
## 4 1967 Afghanistan 9648014150.
## 5 1972 Afghanistan 9678553274.
## 6 1977 Afghanistan 11697659231.
A função arrange serve para ordenar as linhas do tibble.
arrange():## # A tibble: 6 x 26
## date usaf wban code station lat lon elev wd
## <dttm> <chr> <chr> <chr> <chr> <dbl> <dbl> <dbl> <dbl>
## 1 2019-01-01 00:00:00 0377~ 99999 0377~ HEATHR~ 51.5 -0.457 25 284.
## 2 2019-01-01 01:00:00 0377~ 99999 0377~ HEATHR~ 51.5 -0.457 25 287.
## 3 2019-01-01 02:00:00 0377~ 99999 0377~ HEATHR~ 51.5 -0.457 25 290
## 4 2019-01-01 03:00:00 0377~ 99999 0377~ HEATHR~ 51.5 -0.457 25 290
## 5 2019-01-01 04:00:00 0377~ 99999 0377~ HEATHR~ 51.5 -0.457 25 276.
## 6 2019-01-01 05:00:00 0377~ 99999 0377~ HEATHR~ 51.5 -0.457 25 267.
## # ... with 17 more variables: ws <dbl>, ceil_hgt <dbl>, visibility <dbl>,
## # air_temp <dbl>, dew_point <dbl>, atmos_pres <dbl>, RH <dbl>,
## # cl_1 <dbl>, cl_1_height <dbl>, cl_2 <dbl>, cl_2_height <dbl>,
## # cl_3 <dbl>, cl_3_height <dbl>, precip_12 <dbl>, precip_6 <dbl>,
## # cl <dbl>, precip <dbl>
A função desc() permite a ordenação decrescente
## # A tibble: 6 x 26
## date usaf wban code station lat lon elev wd
## <dttm> <chr> <chr> <chr> <chr> <dbl> <dbl> <dbl> <dbl>
## 1 2019-10-13 21:00:00 0377~ 99999 0377~ HEATHR~ 51.5 -0.456 25 207.
## 2 2019-10-13 20:00:00 0377~ 99999 0377~ HEATHR~ 51.5 -0.457 25 228.
## 3 2019-10-13 19:00:00 0377~ 99999 0377~ HEATHR~ 51.5 -0.457 25 240.
## 4 2019-10-13 18:00:00 0377~ 99999 0377~ HEATHR~ 51.5 -0.457 25 250.
## 5 2019-10-13 17:00:00 0377~ 99999 0377~ HEATHR~ 51.5 -0.457 25 250.
## 6 2019-10-13 16:00:00 0377~ 99999 0377~ HEATHR~ 51.5 -0.457 25 247.
## # ... with 17 more variables: ws <dbl>, ceil_hgt <dbl>, visibility <dbl>,
## # air_temp <dbl>, dew_point <dbl>, atmos_pres <dbl>, RH <dbl>,
## # cl_1 <dbl>, cl_1_height <dbl>, cl_2 <dbl>, cl_2_height <dbl>,
## # cl_3 <dbl>, cl_3_height <dbl>, precip_12 <dbl>, precip_6 <dbl>,
## # cl <dbl>, precip <dbl>
filter():filter() seleciona colunas de acordo com os seus valores
filter() (cont.):Filtrando países (note o operador %in%)
gapminder %>%
filter(country %in% c("Brazil", "Argentina", "Chile")) %>%
ggplot() +
geom_line(aes(x = year, y = gdpPercap, color = country )) +
geom_point(aes(x = year, y = gdpPercap, color = country )) +
theme_light()top_n():top_n seleciona as n linhas maiores de acordo com uma das colunas.
top_n() (cont.):Selecionando os países mais ricos em 2007.
Depois aprenderemos como ordenar essas barras
gapminder %>%
filter(year == 2007) %>%
top_n(5, gdpPercap) %>%
ggplot() +
geom_col(aes(x = country, y = gdpPercap)) +
theme_light() top_frac():top_frac():ricos <- gapminder %>%
filter(year == 2007) %>%
top_frac(.2, gdpPercap ) %>%
mutate(categoria = "Rico")
pobres <- gapminder %>%
filter(year == 2007) %>%
top_frac(.2, desc(gdpPercap) ) %>%
mutate(categoria = "Pobre")
bind_rows(ricos, pobres) %>%
ggplot(aes(x = gdpPercap, y = lifeExp)) +
geom_point( aes(color = continent)) +
facet_grid(. ~ categoria, scales = "free_x") +
geom_smooth(method = "lm", se = FALSE) +
theme_light()slice():slice():classificacao_brasileirao <- read_html("https://pt.wikipedia.org/wiki/Campeonato_Brasileiro_de_Futebol_de_2019_-_S%C3%A9rie_A") %>%
html_nodes("table") %>%
extract2(8) %>%
html_table()
limbo <- classificacao_brasileirao %>%
slice(12:16) %>%
select(time = Equipes )
limbo## time
## 1 Vasco da Gama
## 2 Botafogo
## 3 Fluminense
## 4 Fortaleza
## 5 Ceará
group_by():group_by():A função group_by será bastante usada.
Quem conhece SQL pode estranhar um pouco o comportamento desta função, pois ela não agrupa os dados diminuindo o número de linhas imediatamente.
Mas veja que ela indica que há agrupamento
Ela particiona o tibble. As operações passam a ser executadas em cada partição.
## # A tibble: 682 x 3
## # Groups: country [152]
## country date value
## * <chr> <chr> <dbl>
## 1 Albania 2012 29
## 2 Albania 2008 30
## 3 Algeria 2011 27.6
## 4 Angola 2008 42.7
## 5 Argentina 2017 41.2
## 6 Argentina 2016 42
## 7 Argentina 2014 41.7
## 8 Argentina 2013 41
## 9 Argentina 2012 41.4
## 10 Argentina 2011 42.7
## # ... with 672 more rows
group_by() (cont.):Para várias operações, o agrupamento faz com que o comportamento seja diferente.
Uma operação bastante usada é numerar as linhas de um tibble.
No tibble agrupado, essa operação acontece em cada grupo.
group_by() (cont.):As funções lag() e lead() funcionam dentro de cada grupo (o primeiro value de um grupo não acessa o valor do outro grupo com lag() .
summarise() (cont.):group_by() (cont.):A função group_by só leva a uma sumarização, ou seja, só transforma o tibble em um tibble com o número de linhas igual ao número de grupos, quando executamos a função summarise()
Se executarmos summarise sem particionar o tibble, a operação resulta em uma linha.
maiores_temp_dia <- dados_heathrow %>%
group_by(date(date)) %>%
summarise(
maxima = max(air_temp),
minima = min(air_temp),
media = mean(air_temp)
)
datatable(maiores_temp_dia) %>%
formatRound(c("maxima", "minima", "media"), 1)A função top_n retorna os n maiores valores. Se o tibble estiver agrupado, pra cada grupo.
maiores_temp_dia <- dados_heathrow %>%
group_by(date(date)) %>%
top_n(1, air_temp) %>%
ungroup() %>%
mutate(
hora = hour(date),
estacao =
case_when(
month(date) %in% 1:3 ~ "Inverno",
month(date) %in% 7:9 ~ "Verão",
TRUE ~ "Outono/Primavera"
)
) %>%
select(hora, estacao, air_temp)
ggplot(maiores_temp_dia) +
geom_density( aes(x = hora, color = estacao )) +
theme_light()Até agora acessamos dados que estavam disponíveis em bibliotecas, mas muitas vezes encontramos dados em arquivos.
De modo geral, as funções da biblioteca readr são mas rápidas do que as da biblioteca base, e também mostram barra de progresso no console. É possível reconhecê-las pelo _ ao invés de .
O caso mais comum é ler dados em formato de tabela para um tibble
Fonte: (RStudio 2019a)
O portal da CVM é uma das minas de ouro de dados
O código abaixo baixa os dados que ainda não estão na nossa base
existem <- tibble(arquivo = list.files("dados/fundos"))
salva <- function(dado){
endereco <- pull(dado, endereco)
arquivo <- pull(dado, arquivo)
print(endereco)
conteudo <- read_csv2(endereco)
write_csv(conteudo, paste0("dados/fundos/",arquivo))
}
baixa_faltantes <- tibble(data_dado = seq(ymd("2017-01-01"), by = "month", ymd(today()) )) %>%
mutate(data_formato = stamp_date("999912")(data_dado)) %>%
mutate(
endereco = paste0(
"http://dados.cvm.gov.br/dados/FI/DOC/INF_DIARIO/DADOS/",
"inf_diario_fi_",
data_formato,
".csv")) %>%
mutate(arquivo = paste("inf_diario_fi_",data_formato,".csv")) %>%
anti_join(existem, by = c("arquivo" = "arquivo")) %>%
select(-data_formato) %>%
group_by(data_dado) %>%
nest() %>%
mutate(data = map(data, salva ))
le_arquivo <- function(lista_arquivo){
arquivo <- pull(lista_arquivo, arquivo)
conteudo <- read_csv(arquivo)
conteudo
}
todos_os_fundos <- tibble(arquivo = list.files("dados/fundos")) %>%
mutate(arquivo = paste0("dados/fundos/",arquivo )) %>%
group_by(row_number()) %>%
nest() %>%
mutate(data = map(data, le_arquivo)) %>%
unnest()
head(todos_os_fundos)## # A tibble: 6 x 9
## # Groups: row_number() [1]
## `row_number()` CNPJ_FUNDO DT_COMPTC VL_TOTAL VL_QUOTA VL_PATRIM_LIQ
## <int> <chr> <date> <dbl> <dbl> <dbl>
## 1 1 00.017.02~ 2017-01-02 1.08e8 2.43e13 108099858
## 2 1 00.017.02~ 2017-01-03 1.08e8 2.43e13 108144909
## 3 1 00.017.02~ 2017-01-04 1.08e8 2.43e13 108188649
## 4 1 00.017.02~ 2017-01-05 1.08e8 2.43e13 108234509
## 5 1 00.017.02~ 2017-01-06 1.08e8 2.43e13 108278954
## 6 1 00.017.02~ 2017-01-09 1.08e8 2.43e13 108321610
## # ... with 3 more variables: CAPTC_DIA <dbl>, RESG_DIA <dbl>,
## # NR_COTST <dbl>
## # A tibble: 697 x 9
## # Groups: row_number() [34]
## `row_number()` CNPJ_FUNDO DT_COMPTC VL_TOTAL VL_QUOTA VL_PATRIM_LIQ
## <int> <chr> <date> <dbl> <dbl> <dbl>
## 1 1 07.455.50~ 2017-01-02 1.31e12 8.61e12 1312862006441
## 2 1 07.455.50~ 2017-01-03 1.31e12 8.62e12 1311291630745
## 3 1 07.455.50~ 2017-01-04 1.30e12 8.58e12 1305299654809
## 4 1 07.455.50~ 2017-01-05 1.29e12 8.55e12 1300213664841
## 5 1 07.455.50~ 2017-01-06 1.30e12 8.56e12 1301706718495
## 6 1 07.455.50~ 2017-01-09 1.30e12 8.55e12 1300644945751
## 7 1 07.455.50~ 2017-01-10 1.30e12 8.55e12 1300428226690
## 8 1 07.455.50~ 2017-01-11 1.30e12 8.53e12 1296492684946
## 9 1 07.455.50~ 2017-01-12 1.32e12 8.60e12 1332935151782
## 10 1 07.455.50~ 2017-01-13 1.33e12 8.61e12 1333437691636
## # ... with 687 more rows, and 3 more variables: CAPTC_DIA <dbl>,
## # RESG_DIA <dbl>, NR_COTST <dbl>
Uma página WEB pode ser representada por uma árvore de objetos, também chamada de DOM (Document Object Model).
Esta árvore de objetos é definida pelo conteúdo de linguagem html que existe na página (e pode ser modificado por scripts em javascript e definições de estilo do CSS).
Podem existir objetos de vários tipos em uma página: links, inputs de dados, tabelas, células de tabelas, parágrafos, cabeçalhos etc.
Para retirar da página web o conteúdo de que precisamos, temos que analisar como é esta árvore de objetos e que nós desta árvore nos interessam.
Imagine que queremos buscar dados na página de histórico de preços e taxas dos títulos brasileiros
A tecla F12 do Chrome nos permite ver a árvore DOM da página em que estamos navegando.
É possível clicar com o botão direito e inspecionar um elementos específico de forma a saber onde ele está na árvore e que tipo de elemento ele é (mesmo que você saiba pouco de html).
O mais importante é saber que uma tag html que define um elemento tem a sintaxe:
<tipo_elemento nome_atributo=valor_attributo>texto do elemento</tipo_elemento>
Mesmo sem saber hmtl, fica claro que queremos esse tal de atributo href dos tais elementos a seja lá o que diabos isso seja (a é um link e href é o destino do link).
A biblioteca rvest possibilita a extração destes elementos.
É possível caminhar pela árvore DOM até os nós desejados e atributos que queremos usando html_nodes e html_attr.
Munidos de uma função que faz download e salva um arquivo, podemos caminhar pelas planilhas e salvá-las
existem <- tibble(arquivo = list.files("dados/titulos"))
salva_planilha <- function(dado){
arquivo <- pull(dado, endereco)
destino <- pull(dado, name_in)
download.file(
arquivo,
paste0("dados/titulos/",destino,".xls" ),
mode = "wb" ##PRA ARQUIVOS BINÁRIOS,
)
}
links <- read_html("https://sisweb.tesouro.gov.br/apex/f?p=2031:2:0::::") %>%
html_nodes("body") %>%
html_nodes("a") %>%
html_attr("href") %>%
enframe(value = "endereco") %>%
filter(str_detect(endereco, "cosis/sistd/obtem_arquivo/")) %>%
mutate(destino = paste0(name,".xls")) %>%
anti_join(existem, by = c("destino" = "arquivo")) %>%
select(-destino) %>%
mutate(endereco = paste0("https://sisweb.tesouro.gov.br/apex/",endereco) ) %>%
mutate(name_in = name) %>%
group_by(name) %>%
nest() %>%
mutate(data = map(data, salva_planilha ))Agora Vamos organizar as planilhas que lemos do site do tesouro.
Vamos usar a biblioteca read_xl.
Precisamos ler todas as sheets de todos os arquivos em um diretório (onde baixamos os arquivos excel do site do tesouro).
A função abaixo lê as sheets de um arquivo.
le_sheets <- function(dados){
arquivo <- pull(dados, arquivo)
excel_sheets(paste0("dados/titulos/",arquivo))
}A função abaixo lê o conteúdo de cada sheet
Munidos destas duas funções, podemos guardar tudo em um só data frame.
Primeiro, definindo as sheets a ler
sheets_pra_ler <- list.files("dados/titulos") %>%
enframe(value = "arquivo") %>%
mutate(arquivo_out = arquivo) %>%
group_by(name, arquivo_out) %>%
nest() %>%
mutate(data = map(data, le_sheets)) %>%
unnest() %>%
rename(
arquivo = arquivo_out,
sheet = data
)Depois lendo as sheets para um data frame
sheets_lidas <- sheets_pra_ler %>%
mutate(titulo = str_extract(sheet,"[^[0-9]]*" )) %>%
mutate(vencimento = str_extract(sheet,"[0-9]{6}" )) %>%
mutate(vencimento = dmy(vencimento)) %>%
mutate(
arquivo_out = arquivo,
sheet_out = sheet
) %>%
group_by(name, titulo, vencimento, arquivo_out, sheet_out) %>%
nest() %>%
mutate(data = map(data, le_conteudo_sheet)) %>%
unnest() %>%
ungroup()Uma última arrumada
taxas_titulos <- sheets_lidas %>%
rename(
data = 6,
taxa_compra_manha = 7,
taxa_venda_manha = 8,
pu_compra_manha = 9,
pu_venda_manha = 10,
pu_base_manha = 11
) %>%
mutate(
data = if_else(
str_detect(data, "/"),
dmy(data),
as.numeric(data) + ymd("1899-12-31")
)
) %>%
mutate(
titulo = str_trim(titulo),
taxa_compra_manha = as.numeric(taxa_compra_manha),
taxa_venda_manha = as.numeric(taxa_venda_manha),
pu_compra_manha = as.numeric(pu_compra_manha),
pu_venda_manha = as.numeric(pu_venda_manha),
pu_base_manha = as.numeric(pu_base_manha)
) %>%
select(
titulo,
vencimento,
data,
taxa_compra_manha,
taxa_venda_manha,
pu_compra_manha,
pu_venda_manha,
pu_base_manha
) %>%
mutate(
titulo = if_else(
titulo == "NTN-B Principal",
"NTN-B Princ",
titulo
)
)Aí fica fácil fazer a análise que desejarmos
ntnb_2045 <- taxas_titulos %>%
filter(
titulo == "NTN-B Princ",
vencimento == ymd("2045-05-15")
) %>%
mutate(taxa = (taxa_compra_manha +taxa_venda_manha)/2 )
ggplot(ntnb_2045) +
geom_line(aes(x = data, y = taxa) ) +
scale_x_date(
date_breaks = "3 months",
limits = c(ymd("2016-12-01"),NA),
labels = date_format("%m/%y")
) +
scale_y_continuous(
labels = percent_format(accuracy = 0.1)
) +
labs(y = "NTN-B Principal 2045", x = "Data") +
theme_light()##
## Attaching package: 'httr'
## The following object is masked from 'package:caret':
##
## progress
library(rvest)
library(lubridate)
library(tidyverse)
library(magrittr)
url <- "http://www.ceagesp.gov.br/entrepostos/servicos/cotacoes/#cotacao"
le_pagina_ceagesp <- function(grupo, data){
dados <- NA
try({
fd <- list(
cot_grupo = grupo,
cot_data = data
)
resp <- POST(url, body=fd, encode="form")
tabela <- content(resp) %>%
html_nodes("table") %>%
extract2(1) %>%
html_table()
nomes <- tabela %>% slice(2)
dados <- tabela %>% slice(3:nrow(tabela)) %>%
mutate(data = dmy(data))
names(dados) <- c(nomes, "data_precos")
})
str(dados)
dados
}
grupos <- c(
"FRUTAS",
"LEGUMES",
"VERDURAS",
"DIVERSOS",
"FLORES",
"PESCADOS"
)
datas <- seq(from = today()-5, by = 1, to = today()-1) %>%
format("%d/%m/%Y")
dados_ceagesp <- enframe(grupos, value = "grupo", name = "id_grupo") %>%
crossing(enframe(datas, value = "data", name = "id_data")) %>%
mutate(leitura = map2(.x = grupo, .y = data, le_pagina_ceagesp )) %>%
filter(!is.na(leitura)) %>%
unnest(cols = leitura)## 'data.frame': 138 obs. of 8 variables:
## $ Produto : chr "ABACATE AVOCADO" "ABACATE BREDA" "ABACATE BREDA" "ABACATE MARGARIDA" ...
## $ Classificação: chr "A" "A BOCA 8 a 10" "B BOCA 11 e 12" "A BOCA 8 a 10" ...
## $ Uni/Peso : chr "KG" "KG" "KG" "KG" ...
## $ Menor : chr "13,49" "5,86" "5,41" "3,52" ...
## $ Comun : chr "14,49" "6,11" "5,63" "3,7" ...
## $ Maior : chr "15,52" "6,37" "5,88" "3,92" ...
## $ Quilo : chr "1" "1" "1" "1" ...
## $ data_precos : Date, format: "2019-10-10" "2019-10-10" ...
## 'data.frame': 138 obs. of 8 variables:
## $ Produto : chr "ABACATE AVOCADO" "ABACATE BREDA" "ABACATE BREDA" "ABACATE MARGARIDA" ...
## $ Classificação: chr "A" "A BOCA 8 a 10" "B BOCA 11 e 12" "A BOCA 8 a 10" ...
## $ Uni/Peso : chr "KG" "KG" "KG" "KG" ...
## $ Menor : chr "13,65" "5,86" "5,41" "3,53" ...
## $ Comun : chr "14,65" "6,11" "5,63" "3,71" ...
## $ Maior : chr "15,68" "6,37" "5,88" "3,93" ...
## $ Quilo : chr "1" "1" "1" "1" ...
## $ data_precos : Date, format: "2019-10-11" "2019-10-11" ...
## Error in extract2(., 1) : índice fora de limites
## logi NA
## Error in extract2(., 1) : índice fora de limites
## logi NA
## 'data.frame': 140 obs. of 8 variables:
## $ Produto : chr "ABACATE AVOCADO" "ABACATE BREDA" "ABACATE BREDA" "ABACATE MARGARIDA" ...
## $ Classificação: chr "A" "A BOCA 8 a 10" "B BOCA 11 e 12" "A BOCA 8 a 10" ...
## $ Uni/Peso : chr "KG" "KG" "KG" "KG" ...
## $ Menor : chr "13,65" "5,83" "5,44" "3,35" ...
## $ Comun : chr "14,65" "6,1" "5,62" "3,53" ...
## $ Maior : chr "15,68" "6,29" "5,85" "3,7" ...
## $ Quilo : chr "1" "1" "1" "1" ...
## $ data_precos : Date, format: "2019-10-14" "2019-10-14" ...
## 'data.frame': 98 obs. of 8 variables:
## $ Produto : chr "ABOBORA JAPONESA" "ABOBORA MORANGA" "ABOBORA PAULISTA" "ABOBORA SECA" ...
## $ Classificação: chr "-" "-" "-" "-" ...
## $ Uni/Peso : chr "KG" "KG" "KG" "KG" ...
## $ Menor : chr "1,26" "1,14" "1,39" "1,76" ...
## $ Comun : chr "1,47" "1,37" "1,53" "2,01" ...
## $ Maior : chr "1,69" "1,56" "1,69" "2,33" ...
## $ Quilo : chr "1" "1" "1" "1" ...
## $ data_precos : Date, format: "2019-10-10" "2019-10-10" ...
## 'data.frame': 98 obs. of 8 variables:
## $ Produto : chr "ABOBORA JAPONESA" "ABOBORA MORANGA" "ABOBORA PAULISTA" "ABOBORA SECA" ...
## $ Classificação: chr "-" "-" "-" "-" ...
## $ Uni/Peso : chr "KG" "KG" "KG" "KG" ...
## $ Menor : chr "1,26" "1,14" "1,39" "1,76" ...
## $ Comun : chr "1,47" "1,37" "1,53" "2,01" ...
## $ Maior : chr "1,69" "1,56" "1,69" "2,33" ...
## $ Quilo : chr "1" "1" "1" "1" ...
## $ data_precos : Date, format: "2019-10-11" "2019-10-11" ...
## Error in extract2(., 1) : índice fora de limites
## logi NA
## Error in extract2(., 1) : índice fora de limites
## logi NA
## 'data.frame': 98 obs. of 8 variables:
## $ Produto : chr "ABOBORA JAPONESA" "ABOBORA MORANGA" "ABOBORA PAULISTA" "ABOBORA SECA" ...
## $ Classificação: chr "-" "-" "-" "-" ...
## $ Uni/Peso : chr "KG" "KG" "KG" "KG" ...
## $ Menor : chr "1,34" "1,15" "1,43" "1,81" ...
## $ Comun : chr "1,58" "1,38" "1,59" "2,08" ...
## $ Maior : chr "1,81" "1,58" "1,77" "2,38" ...
## $ Quilo : chr "1" "1" "1" "1" ...
## $ data_precos : Date, format: "2019-10-14" "2019-10-14" ...
## 'data.frame': 89 obs. of 8 variables:
## $ Produto : chr "ACELGA" "ACELGA" "ACELGA" "AGRIAO" ...
## $ Classificação: chr "ESPECIAL" "EXTRA" "PRIMEIRA" "ESPECIAL" ...
## $ Uni/Peso : chr "ENG" "ENG" "ENG" "ENG" ...
## $ Menor : chr "8,76" "11,48" "6,08" "16,34" ...
## $ Comun : chr "9,76" "12,48" "7,08" "17,74" ...
## $ Maior : chr "10,76" "13,48" "8,08" "19,14" ...
## $ Quilo : chr "12" "12" "12" "12" ...
## $ data_precos : Date, format: "2019-10-10" "2019-10-10" ...
## 'data.frame': 89 obs. of 8 variables:
## $ Produto : chr "ACELGA" "ACELGA" "ACELGA" "AGRIAO" ...
## $ Classificação: chr "ESPECIAL" "EXTRA" "PRIMEIRA" "ESPECIAL" ...
## $ Uni/Peso : chr "ENG" "ENG" "ENG" "ENG" ...
## $ Menor : chr "8,37" "11,09" "5,47" "16,11" ...
## $ Comun : chr "9,37" "12,09" "6,47" "17,52" ...
## $ Maior : chr "10,37" "13,09" "7,47" "18,92" ...
## $ Quilo : chr "12" "12" "12" "12" ...
## $ data_precos : Date, format: "2019-10-11" "2019-10-11" ...
## Error in extract2(., 1) : índice fora de limites
## logi NA
## Error in extract2(., 1) : índice fora de limites
## logi NA
## 'data.frame': 89 obs. of 8 variables:
## $ Produto : chr "ACELGA" "ACELGA" "ACELGA" "AGRIAO" ...
## $ Classificação: chr "ESPECIAL" "EXTRA" "PRIMEIRA" "ESPECIAL" ...
## $ Uni/Peso : chr "ENG" "ENG" "ENG" "ENG" ...
## $ Menor : chr "8,37" "11,09" "5,47" "15,77" ...
## $ Comun : chr "9,37" "12,09" "6,47" "17,17" ...
## $ Maior : chr "10,37" "13,09" "7,47" "18,57" ...
## $ Quilo : chr "12" "12" "12" "12" ...
## $ data_precos : Date, format: "2019-10-14" "2019-10-14" ...
## 'data.frame': 36 obs. of 8 variables:
## $ Produto : chr "ALHO" "ALHO" "ALHO" "ALHO ESTRANG. CHINES" ...
## $ Classificação: chr "TIPO 5" "TIPO 6" "TIPO 7" "TIPO 6/7" ...
## $ Uni/Peso : chr "KG" "KG" "KG" "KG" ...
## $ Menor : chr "12,98" "14,98" "16,98" "13" ...
## $ Comun : chr "13,98" "15,98" "17,98" "14" ...
## $ Maior : chr "14,98" "16,98" "18,98" "15" ...
## $ Quilo : chr "1" "1" "1" "1" ...
## $ data_precos : Date, format: "2019-10-10" "2019-10-10" ...
## 'data.frame': 36 obs. of 8 variables:
## $ Produto : chr "ALHO" "ALHO" "ALHO" "ALHO ESTRANG. CHINES" ...
## $ Classificação: chr "TIPO 5" "TIPO 6" "TIPO 7" "TIPO 6/7" ...
## $ Uni/Peso : chr "KG" "KG" "KG" "KG" ...
## $ Menor : chr "12,98" "14,98" "16,98" "13" ...
## $ Comun : chr "13,98" "15,98" "17,98" "14" ...
## $ Maior : chr "14,98" "16,98" "18,98" "15" ...
## $ Quilo : chr "1" "1" "1" "1" ...
## $ data_precos : Date, format: "2019-10-11" "2019-10-11" ...
## Error in extract2(., 1) : índice fora de limites
## logi NA
## Error in extract2(., 1) : índice fora de limites
## logi NA
## 'data.frame': 36 obs. of 8 variables:
## $ Produto : chr "ALHO" "ALHO" "ALHO" "ALHO ESTRANG. CHINES" ...
## $ Classificação: chr "TIPO 5" "TIPO 6" "TIPO 7" "TIPO 6/7" ...
## $ Uni/Peso : chr "KG" "KG" "KG" "KG" ...
## $ Menor : chr "12,98" "14,98" "16,98" "13" ...
## $ Comun : chr "13,98" "15,98" "17,98" "14" ...
## $ Maior : chr "14,98" "16,98" "18,98" "15" ...
## $ Quilo : chr "1" "1" "1" "1" ...
## $ data_precos : Date, format: "2019-10-14" "2019-10-14" ...
## Error in extract2(., 1) : índice fora de limites
## logi NA
## 'data.frame': 61 obs. of 8 variables:
## $ Produto : chr "ALSTROMERIA" "ANGELICA" "ANTURIO" "ANTURIO" ...
## $ Classificação: chr "-" "-" "CABO CURTO" "CABO LONGO" ...
## $ Uni/Peso : chr "MC" "DZ" "DZ" "DZ" ...
## $ Menor : chr "6,4" "9,33" "31" "42,52" ...
## $ Comun : chr "7,1" "9,88" "33" "44,52" ...
## $ Maior : chr "7,8" "10,42" "35" "46,52" ...
## $ Quilo : chr "0,4" "1,5" "0,15" "0,15" ...
## $ data_precos : Date, format: "2019-10-11" "2019-10-11" ...
## Error in extract2(., 1) : índice fora de limites
## logi NA
## Error in extract2(., 1) : índice fora de limites
## logi NA
## Error in extract2(., 1) : índice fora de limites
## logi NA
## 'data.frame': 62 obs. of 8 variables:
## $ Produto : chr "ABROTEA" "ABROTEA" "ABROTEA" "ATUM" ...
## $ Classificação: chr "GRANDE" "MEDIA" "PEQUENA" "GRANDE" ...
## $ Uni/Peso : chr "KG" "KG" "KG" "KG" ...
## $ Menor : chr "8" "4" "3" "15" ...
## $ Comun : chr "9" "5" "3,5" "18" ...
## $ Maior : chr "10" "6" "4" "20" ...
## $ Quilo : chr "1" "1" "1" "1" ...
## $ data_precos : Date, format: "2019-10-10" "2019-10-10" ...
## 'data.frame': 66 obs. of 8 variables:
## $ Produto : chr "ABROTEA" "ABROTEA" "ABROTEA" "ANCHOVAS" ...
## $ Classificação: chr "GRANDE" "MEDIA" "PEQUENA" "GRANDE" ...
## $ Uni/Peso : chr "KG" "KG" "KG" "KG" ...
## $ Menor : chr "7" "4" "3" "10" ...
## $ Comun : chr "8" "5" "3,5" "11" ...
## $ Maior : chr "9" "6" "4" "12" ...
## $ Quilo : chr "1" "1" "1" "1" ...
## $ data_precos : Date, format: "2019-10-11" "2019-10-11" ...
## Error in extract2(., 1) : índice fora de limites
## logi NA
## Error in extract2(., 1) : índice fora de limites
## logi NA
## 'data.frame': 40 obs. of 8 variables:
## $ Produto : chr "ABROTEA" "ANCHOVAS" "ATUM" "ATUM" ...
## $ Classificação: chr "GRANDE" "MEDIA" "GRANDE" "MEDIO" ...
## $ Uni/Peso : chr "KG" "KG" "KG" "KG" ...
## $ Menor : chr "8" "9" "15" "10" ...
## $ Comun : chr "9" "9,5" "18" "12" ...
## $ Maior : chr "10" "10" "20" "15" ...
## $ Quilo : chr "1" "1" "1" "1" ...
## $ data_precos : Date, format: "2019-10-14" "2019-10-14" ...
## # A tibble: 6 x 12
## id_grupo grupo id_data data Produto Classificação `Uni/Peso` Menor Comun
## <int> <chr> <int> <chr> <chr> <chr> <chr> <chr> <chr>
## 1 1 FRUT~ 1 10/1~ ABACAT~ A KG 13,49 14,49
## 2 1 FRUT~ 1 10/1~ ABACAT~ A BOCA 8 a 10 KG 5,86 6,11
## 3 1 FRUT~ 1 10/1~ ABACAT~ B BOCA 11 e ~ KG 5,41 5,63
## 4 1 FRUT~ 1 10/1~ ABACAT~ A BOCA 8 a 10 KG 3,52 3,7
## 5 1 FRUT~ 1 10/1~ ABACAT~ B BOCA 11 e ~ KG 3,18 3,38
## 6 1 FRUT~ 1 10/1~ ABACAX~ A GRAUDO UND 5,01 5,51
## # ... with 3 more variables: Maior <chr>, Quilo <chr>, data_precos <date>
Nem todas as páginas são fáceis de ler.
A página que mostra os DIs na BMF, por exemplo é esquisita:
O nosso objeto de interesse aparece na ferramenta chamada por F12, mas não é encontrada pela rvest ao ler o HTML
Existem duas técnicas para o Web Scraping:
Simular a navegação num browser emulado (fora do escopo deste curso)
Interpretar páginas com base no conteúdo recebido
Na página que visualizamos da BMF, o conteúdo recebido inclui um script javascript que popula a tabela, por isso não conseguimos reconhecer o conteúdo da tabela de pronto, pois ela só é carregada pela execução do script.
Conseguimos, no entanto, extrair do script as informações de que precisamos
O código abaixo extrai da página as informações de que precisamos.
Para extrair as informações, ele usa expressões regulares.
Repare na função que silencia um possível erro. Este erro pode acontecer se passarmos um dia que não tem dados. Precisamos disso pois vamos buscar todas as datas possíveis.
Essa não é a melhor forma de tratar um erro deste tipo. Veremos mais adiante
cotacoes <- tibble(
id = 0:10,
cotacao = c(
"ajuste_ant",
"ajuste_corrig",
"preco_abert",
"preco_min",
"preco_max",
"preco_med",
"ult_preco",
"ajuste",
"var_pontos",
"ult_of_compra",
"ult_of_venda"
)
)
#QUEM INVENTOU ISSO?
siglas_mes <- tibble(
sigla_mes = c(
"F",
"G",
"H",
"J",
"K",
"M",
"N",
"Q",
"U",
"V",
"X",
"Z"
),
mes = 1:12
)
pagina <- NA
try(
{pagina <- read_html("http://www2.bmf.com.br/pages/portal/bmfbovespa/boletim1/SistemaPregao1.asp?pagetype=pop&caminho=Resumo%20Estat%EDstico%20-%20Sistema%20Preg%E3o&Data=10/01/2017&Mercadoria=DI1") %>%
html_nodes("script") %>%
extract2(13) %>%
html_text()}
,
silent = TRUE
)
linhas_impares <- str_extract_all(pagina, "MercFut1 \\+ '<td ALIGN=\"right\" CLASS=\"tabelaConteudo1\">[0-9.,]*") %>%
extract2(1) %>%
enframe() %>%
mutate(
ativo = (row_number()-1) %/% 11 * 2,
tipo_cotacao = (row_number() - 1) %% 11
)
linhas_pares <- str_extract_all(pagina, "MercFut1 \\+ '<td ALIGN=\"right\" CLASS=\"tabelaConteudo2\">[0-9.,]*") %>%
extract2(1) %>%
enframe() %>%
mutate(
ativo = (row_number()-1) %/% 11 * 2 + 1,
tipo_cotacao = (row_number() - 1) %% 11
)
linhas <- linhas_impares %>%
bind_rows(linhas_pares) %>%
arrange(ativo) %>%
mutate(valor = str_extract_all(value, ">[0-9.,]*")) %>%
mutate(valor = str_sub(valor, 2)) %>%
select(ativo, tipo_cotacao, valor)
ativos <- str_extract_all(pagina, "MercFut3 = MercFut3 \\+ '</tr><td ALIGN=\"center\" CLASS=\"tabelaConteudo[0-9]\">[A-Z][0-9][0-9]") %>%
extract2(1) %>%
enframe() %>%
mutate(
nome_ativo = str_sub(value,-3),
id = name - 1
) %>%
select(
id,
nome_ativo
)
linhas %<>% left_join(ativos, by = c("ativo" = "id")) %>%
select(nome_ativo, tipo_cotacao, valor) %>%
mutate(
sigla_mes = str_sub(nome_ativo, 1,1),
ano = as.numeric(str_sub(nome_ativo, 2,4)) + 2000
) %>%
left_join(cotacoes, by = c("tipo_cotacao" = "id") ) %>%
left_join(siglas_mes, by = c("sigla_mes")) %>%
mutate(vencimento = make_date(ano, mes, 1)) %>%
mutate(
valor = parse_number(
valor,
locale = locale(
decimal_mark = ",",
grouping_mark = "."
)
)
) %>%
select(
nome_ativo,
vencimento,
cotacao,
valor
)Agora vamos executar para todos os dias desde janeiro de 2017.
Preparamos a função…
le_uma_pagina_bmf <- function(dados){
data <- pull(dados, data_in) %>%
stamp_date("31/01/2017")(.)
pagina <- NA
try(
{pagina <- read_html(paste0("http://www2.bmf.com.br/pages/portal/bmfbovespa/boletim1/SistemaPregao1.asp?pagetype=pop&caminho=Resumo%20Estat%EDstico%20-%20Sistema%20Preg%E3o&Data=",data,"&Mercadoria=DI1")) %>%
html_nodes("script") %>%
extract2(13) %>%
html_text()}
,
silent = TRUE
)
if (!is.na(pagina)){
linhas_impares <- str_extract_all(pagina, "MercFut1 \\+ '<td ALIGN=\"right\" CLASS=\"tabelaConteudo1\">[0-9.,]*") %>%
extract2(1) %>%
enframe() %>%
mutate(
ativo = (row_number()-1) %/% 11 * 2,
tipo_cotacao = (row_number() - 1) %% 11
)
linhas_pares <- str_extract_all(pagina, "MercFut1 \\+ '<td ALIGN=\"right\" CLASS=\"tabelaConteudo2\">[0-9.,]*") %>%
extract2(1) %>%
enframe() %>%
mutate(
ativo = (row_number()-1) %/% 11 * 2 + 1,
tipo_cotacao = (row_number() - 1) %% 11
)
linhas <- linhas_impares %>%
bind_rows(linhas_pares) %>%
arrange(ativo) %>%
mutate(valor = str_extract_all(value, ">[0-9.,]*")) %>%
mutate(valor = str_sub(valor, 2)) %>%
select(ativo, tipo_cotacao, valor)
ativos <- str_extract_all(pagina, "MercFut3 = MercFut3 \\+ '</tr><td ALIGN=\"center\" CLASS=\"tabelaConteudo[0-9]\">[A-Z][0-9][0-9]") %>%
extract2(1) %>%
enframe() %>%
mutate(
nome_ativo = str_sub(value,-3),
id = name - 1
) %>%
select(
id,
nome_ativo
)
linhas %<>% left_join(ativos, by = c("ativo" = "id")) %>%
select(nome_ativo, tipo_cotacao, valor) %>%
mutate(
sigla_mes = str_sub(nome_ativo, 1,1),
ano = as.numeric(str_sub(nome_ativo, 2,4)) + 2000
) %>%
left_join(cotacoes, by = c("tipo_cotacao" = "id") ) %>%
left_join(siglas_mes, by = c("sigla_mes")) %>%
mutate(vencimento = make_date(ano, mes, 1)) %>%
mutate(
valor = parse_number(
valor,
locale = locale(
decimal_mark = ",",
grouping_mark = "."
)
)
) %>%
select(
nome_ativo,
vencimento,
cotacao,
valor
)
linhas
}
else
{
tibble(dia_inutil = TRUE )
}
}E executamos para todos os dias.
O data frame com todos os dados ficou assim.
Veja como as funções da biblioteca kable e kableExtra dão mais controle na criação das tabelas.
Note como ele ainda não está “Tidy”. Por quê?
dados_todas_as_datas %>%
ungroup() %>%
filter(is.na(dia_inutil)) %>%
select(-dia_inutil, - name) %>%
head(n = 200) %>%
mutate(
data_out = stamp_date("31/12/2010")(data_out),
vencimento = stamp_date("12/%Y")(vencimento),
valor = number(valor, accuracy = 0.001, decimal.mark = ",", big.mark = ".")
) %>%
kable(
col.names =
c(
"Data",
"Ativo",
"Vencimento",
"Tipo Cotação",
"Cotação"
),
align =
c("l","l","l","l","r")
) %>%
kable_styling(
) %>%
row_spec(
seq(2, 200, 2),
background = "#eeeeee"
) | Data | Ativo | Vencimento | Tipo Cotação | Cotação |
|---|---|---|---|---|
| 02/01/2017 | F17 | 01/2017 | ajuste_ant | 99.999,980 |
| 02/01/2017 | F17 | 01/2017 | ajuste_corrig | 100.050,710 |
| 02/01/2017 | F17 | 01/2017 | preco_abert | 0,000 |
| 02/01/2017 | F17 | 01/2017 | preco_min | 0,000 |
| 02/01/2017 | F17 | 01/2017 | preco_max | 0,000 |
| 02/01/2017 | F17 | 01/2017 | preco_med | 0,000 |
| 02/01/2017 | F17 | 01/2017 | ult_preco | 0,000 |
| 02/01/2017 | F17 | 01/2017 | ajuste | 100.000,000 |
| 02/01/2017 | F17 | 01/2017 | var_pontos | 0,020 |
| 02/01/2017 | F17 | 01/2017 | ult_of_compra | 0,000 |
| 02/01/2017 | F17 | 01/2017 | ult_of_venda | 0,000 |
| 02/01/2017 | G17 | 02/2017 | ajuste_ant | 98.918,060 |
| 02/01/2017 | G17 | 02/2017 | ajuste_corrig | 13,280 |
| 02/01/2017 | G17 | 02/2017 | preco_abert | 13,270 |
| 02/01/2017 | G17 | 02/2017 | preco_min | 13,280 |
| 02/01/2017 | G17 | 02/2017 | preco_max | 13,272 |
| 02/01/2017 | G17 | 02/2017 | preco_med | 13,271 |
| 02/01/2017 | G17 | 02/2017 | ult_preco | 98.918,080 |
| 02/01/2017 | G17 | 02/2017 | ajuste | 0,020 |
| 02/01/2017 | G17 | 02/2017 | var_pontos | 13,271 |
| 02/01/2017 | G17 | 02/2017 | ult_of_compra | 13,274 |
| 02/01/2017 | G17 | 02/2017 | ult_of_venda | 97.013,860 |
| 02/01/2017 | H17 | 03/2017 | ajuste_ant | 98.058,480 |
| 02/01/2017 | H17 | 03/2017 | ajuste_corrig | 98.107,120 |
| 02/01/2017 | H17 | 03/2017 | preco_abert | 13,150 |
| 02/01/2017 | H17 | 03/2017 | preco_min | 13,150 |
| 02/01/2017 | H17 | 03/2017 | preco_max | 13,156 |
| 02/01/2017 | H17 | 03/2017 | preco_med | 13,154 |
| 02/01/2017 | H17 | 03/2017 | ult_preco | 13,155 |
| 02/01/2017 | H17 | 03/2017 | ajuste | 98.057,400 |
| 02/01/2017 | H17 | 03/2017 | var_pontos | 1,080 |
| 02/01/2017 | H17 | 03/2017 | ult_of_compra | 13,150 |
| 02/01/2017 | H17 | 03/2017 | ult_of_venda | 13,160 |
| 02/01/2017 | J17 | 04/2017 | ajuste_ant | 97.059,280 |
| 02/01/2017 | J17 | 04/2017 | ajuste_corrig | 12,900 |
| 02/01/2017 | J17 | 04/2017 | preco_abert | 12,885 |
| 02/01/2017 | J17 | 04/2017 | preco_min | 12,925 |
| 02/01/2017 | J17 | 04/2017 | preco_max | 12,906 |
| 02/01/2017 | J17 | 04/2017 | preco_med | 12,910 |
| 02/01/2017 | J17 | 04/2017 | ult_preco | 97.010,090 |
| 02/01/2017 | J17 | 04/2017 | ajuste | 3,770 |
| 02/01/2017 | J17 | 04/2017 | var_pontos | 12,900 |
| 02/01/2017 | J17 | 04/2017 | ult_of_compra | 12,910 |
| 02/01/2017 | J17 | 04/2017 | ult_of_venda | 95.282,740 |
| 02/01/2017 | K17 | 05/2017 | ajuste_ant | 96.220,720 |
| 02/01/2017 | K17 | 05/2017 | ajuste_corrig | 96.267,740 |
| 02/01/2017 | K17 | 05/2017 | preco_abert | 12,745 |
| 02/01/2017 | K17 | 05/2017 | preco_min | 12,735 |
| 02/01/2017 | K17 | 05/2017 | preco_max | 12,745 |
| 02/01/2017 | K17 | 05/2017 | preco_med | 12,741 |
| 02/01/2017 | K17 | 05/2017 | ult_preco | 12,740 |
| 02/01/2017 | K17 | 05/2017 | ajuste | 96.218,950 |
| 02/01/2017 | K17 | 05/2017 | var_pontos | 1,770 |
| 02/01/2017 | K17 | 05/2017 | ult_of_compra | 12,740 |
| 02/01/2017 | K17 | 05/2017 | ult_of_venda | 12,755 |
| 02/01/2017 | M17 | 06/2017 | ajuste_ant | 95.330,910 |
| 02/01/2017 | M17 | 06/2017 | ajuste_corrig | 12,550 |
| 02/01/2017 | M17 | 06/2017 | preco_abert | 12,550 |
| 02/01/2017 | M17 | 06/2017 | preco_min | 12,550 |
| 02/01/2017 | M17 | 06/2017 | preco_max | 12,550 |
| 02/01/2017 | M17 | 06/2017 | preco_med | 12,550 |
| 02/01/2017 | M17 | 06/2017 | ult_preco | 95.282,590 |
| 02/01/2017 | M17 | 06/2017 | ajuste | 0,150 |
| 02/01/2017 | M17 | 06/2017 | var_pontos | 12,550 |
| 02/01/2017 | M17 | 06/2017 | ult_of_compra | 0,000 |
| 02/01/2017 | M17 | 06/2017 | ult_of_venda | 93.605,300 |
| 02/01/2017 | N17 | 07/2017 | ajuste_ant | 94.410,120 |
| 02/01/2017 | N17 | 07/2017 | ajuste_corrig | 94.481,010 |
| 02/01/2017 | N17 | 07/2017 | preco_abert | 12,380 |
| 02/01/2017 | N17 | 07/2017 | preco_min | 12,340 |
| 02/01/2017 | N17 | 07/2017 | preco_max | 12,400 |
| 02/01/2017 | N17 | 07/2017 | preco_med | 12,349 |
| 02/01/2017 | N17 | 07/2017 | ult_preco | 12,340 |
| 02/01/2017 | N17 | 07/2017 | ajuste | 94.433,120 |
| 02/01/2017 | N17 | 07/2017 | var_pontos | 23,000 |
| 02/01/2017 | N17 | 07/2017 | ult_of_compra | 12,335 |
| 02/01/2017 | N17 | 07/2017 | ult_of_venda | 12,350 |
| 02/01/2017 | Q17 | 08/2017 | ajuste_ant | 93.674,050 |
| 02/01/2017 | Q17 | 08/2017 | ajuste_corrig | 12,185 |
| 02/01/2017 | Q17 | 08/2017 | preco_abert | 12,160 |
| 02/01/2017 | Q17 | 08/2017 | preco_min | 12,185 |
| 02/01/2017 | Q17 | 08/2017 | preco_max | 12,161 |
| 02/01/2017 | Q17 | 08/2017 | preco_med | 12,160 |
| 02/01/2017 | Q17 | 08/2017 | ult_preco | 93.626,570 |
| 02/01/2017 | Q17 | 08/2017 | ajuste | 21,270 |
| 02/01/2017 | Q17 | 08/2017 | var_pontos | 0,000 |
| 02/01/2017 | Q17 | 08/2017 | ult_of_compra | 0,000 |
| 02/01/2017 | Q17 | 08/2017 | ult_of_venda | 91.983,900 |
| 02/01/2017 | U17 | 09/2017 | ajuste_ant | 92.722,560 |
| 02/01/2017 | U17 | 09/2017 | ajuste_corrig | 92.798,300 |
| 02/01/2017 | U17 | 09/2017 | preco_abert | 11,935 |
| 02/01/2017 | U17 | 09/2017 | preco_min | 11,935 |
| 02/01/2017 | U17 | 09/2017 | preco_max | 11,935 |
| 02/01/2017 | U17 | 09/2017 | preco_med | 11,935 |
| 02/01/2017 | U17 | 09/2017 | ult_preco | 11,935 |
| 02/01/2017 | U17 | 09/2017 | ajuste | 92.751,270 |
| 02/01/2017 | U17 | 09/2017 | var_pontos | 28,710 |
| 02/01/2017 | U17 | 09/2017 | ult_of_compra | 0,000 |
| 02/01/2017 | U17 | 09/2017 | ult_of_venda | 0,000 |
| 02/01/2017 | V17 | 10/2017 | ajuste_ant | 92.043,710 |
| 02/01/2017 | V17 | 10/2017 | ajuste_corrig | 11,850 |
| 02/01/2017 | V17 | 10/2017 | preco_abert | 11,810 |
| 02/01/2017 | V17 | 10/2017 | preco_min | 11,850 |
| 02/01/2017 | V17 | 10/2017 | preco_max | 11,827 |
| 02/01/2017 | V17 | 10/2017 | preco_med | 11,825 |
| 02/01/2017 | V17 | 10/2017 | ult_preco | 91.997,060 |
| 02/01/2017 | V17 | 10/2017 | ajuste | 13,160 |
| 02/01/2017 | V17 | 10/2017 | var_pontos | 11,820 |
| 02/01/2017 | V17 | 10/2017 | ult_of_compra | 11,825 |
| 02/01/2017 | V17 | 10/2017 | ult_of_venda | 90.483,600 |
| 02/01/2017 | X17 | 11/2017 | ajuste_ant | 91.212,090 |
| 02/01/2017 | X17 | 11/2017 | ajuste_corrig | 91.295,710 |
| 02/01/2017 | X17 | 11/2017 | preco_abert | 11,650 |
| 02/01/2017 | X17 | 11/2017 | preco_min | 11,650 |
| 02/01/2017 | X17 | 11/2017 | preco_max | 11,650 |
| 02/01/2017 | X17 | 11/2017 | preco_med | 11,650 |
| 02/01/2017 | X17 | 11/2017 | ult_preco | 11,650 |
| 02/01/2017 | X17 | 11/2017 | ajuste | 91.249,440 |
| 02/01/2017 | X17 | 11/2017 | var_pontos | 37,350 |
| 02/01/2017 | X17 | 11/2017 | ult_of_compra | 0,000 |
| 02/01/2017 | X17 | 11/2017 | ult_of_venda | 0,000 |
| 02/01/2017 | Z17 | 12/2017 | ajuste_ant | 90.589,120 |
| 02/01/2017 | Z17 | 12/2017 | ajuste_corrig | 11,540 |
| 02/01/2017 | Z17 | 12/2017 | preco_abert | 11,540 |
| 02/01/2017 | Z17 | 12/2017 | preco_min | 11,540 |
| 02/01/2017 | Z17 | 12/2017 | preco_max | 11,540 |
| 02/01/2017 | Z17 | 12/2017 | preco_med | 11,540 |
| 02/01/2017 | Z17 | 12/2017 | ult_preco | 90.543,210 |
| 02/01/2017 | Z17 | 12/2017 | ajuste | 59,610 |
| 02/01/2017 | Z17 | 12/2017 | var_pontos | 0,000 |
| 02/01/2017 | Z17 | 12/2017 | ult_of_compra | 0,000 |
| 02/01/2017 | Z17 | 12/2017 | ult_of_venda | 87.645,570 |
| 02/01/2017 | F18 | 01/2018 | ajuste_ant | 89.783,790 |
| 02/01/2017 | F18 | 01/2018 | ajuste_corrig | 89.887,770 |
| 02/01/2017 | F18 | 01/2018 | preco_abert | 11,510 |
| 02/01/2017 | F18 | 01/2018 | preco_min | 11,435 |
| 02/01/2017 | F18 | 01/2018 | preco_max | 11,510 |
| 02/01/2017 | F18 | 01/2018 | preco_med | 11,459 |
| 02/01/2017 | F18 | 01/2018 | ult_preco | 11,440 |
| 02/01/2017 | F18 | 01/2018 | ajuste | 89.842,210 |
| 02/01/2017 | F18 | 01/2018 | var_pontos | 58,420 |
| 02/01/2017 | F18 | 01/2018 | ult_of_compra | 11,440 |
| 02/01/2017 | F18 | 01/2018 | ult_of_venda | 11,450 |
| 02/01/2017 | J18 | 04/2018 | ajuste_ant | 87.782,490 |
| 02/01/2017 | J18 | 04/2018 | ajuste_corrig | 11,250 |
| 02/01/2017 | J18 | 04/2018 | preco_abert | 11,210 |
| 02/01/2017 | J18 | 04/2018 | preco_min | 11,250 |
| 02/01/2017 | J18 | 04/2018 | preco_max | 11,225 |
| 02/01/2017 | J18 | 04/2018 | preco_med | 11,220 |
| 02/01/2017 | J18 | 04/2018 | ult_preco | 87.738,000 |
| 02/01/2017 | J18 | 04/2018 | ajuste | 92,430 |
| 02/01/2017 | J18 | 04/2018 | var_pontos | 0,000 |
| 02/01/2017 | J18 | 04/2018 | ult_of_compra | 0,000 |
| 02/01/2017 | J18 | 04/2018 | ult_of_venda | 83.304,290 |
| 02/01/2017 | N18 | 07/2018 | ajuste_ant | 85.496,480 |
| 02/01/2017 | N18 | 07/2018 | ajuste_corrig | 85.650,460 |
| 02/01/2017 | N18 | 07/2018 | preco_abert | 11,120 |
| 02/01/2017 | N18 | 07/2018 | preco_min | 11,060 |
| 02/01/2017 | N18 | 07/2018 | preco_max | 11,130 |
| 02/01/2017 | N18 | 07/2018 | preco_med | 11,085 |
| 02/01/2017 | N18 | 07/2018 | ult_preco | 11,080 |
| 02/01/2017 | N18 | 07/2018 | ajuste | 85.607,050 |
| 02/01/2017 | N18 | 07/2018 | var_pontos | 110,570 |
| 02/01/2017 | N18 | 07/2018 | ult_of_compra | 11,060 |
| 02/01/2017 | N18 | 07/2018 | ult_of_venda | 11,080 |
| 02/01/2017 | V18 | 10/2018 | ajuste_ant | 83.488,070 |
| 02/01/2017 | V18 | 10/2018 | ajuste_corrig | 11,050 |
| 02/01/2017 | V18 | 10/2018 | preco_abert | 11,000 |
| 02/01/2017 | V18 | 10/2018 | preco_min | 11,050 |
| 02/01/2017 | V18 | 10/2018 | preco_max | 11,015 |
| 02/01/2017 | V18 | 10/2018 | preco_med | 11,010 |
| 02/01/2017 | V18 | 10/2018 | ult_preco | 83.445,750 |
| 02/01/2017 | V18 | 10/2018 | ajuste | 141,460 |
| 02/01/2017 | V18 | 10/2018 | var_pontos | 0,000 |
| 02/01/2017 | V18 | 10/2018 | ult_of_compra | 11,010 |
| 02/01/2017 | V18 | 10/2018 | ult_of_venda | 79.189,040 |
| 02/01/2017 | F19 | 01/2019 | ajuste_ant | 81.272,780 |
| 02/01/2017 | F19 | 01/2019 | ajuste_corrig | 81.415,280 |
| 02/01/2017 | F19 | 01/2019 | preco_abert | 11,000 |
| 02/01/2017 | F19 | 01/2019 | preco_min | 10,930 |
| 02/01/2017 | F19 | 01/2019 | preco_max | 11,030 |
| 02/01/2017 | F19 | 01/2019 | preco_med | 10,968 |
| 02/01/2017 | F19 | 01/2019 | ult_preco | 10,950 |
| 02/01/2017 | F19 | 01/2019 | ajuste | 81.374,020 |
| 02/01/2017 | F19 | 01/2019 | var_pontos | 101,240 |
| 02/01/2017 | F19 | 01/2019 | ult_of_compra | 10,940 |
| 02/01/2017 | F19 | 01/2019 | ult_of_venda | 10,950 |
| 02/01/2017 | J19 | 04/2019 | ajuste_ant | 79.341,870 |
| 02/01/2017 | J19 | 04/2019 | ajuste_corrig | 11,010 |
| 02/01/2017 | J19 | 04/2019 | preco_abert | 10,970 |
| 02/01/2017 | J19 | 04/2019 | preco_min | 11,010 |
| 02/01/2017 | J19 | 04/2019 | preco_max | 11,002 |
| 02/01/2017 | J19 | 04/2019 | preco_med | 10,980 |
| 02/01/2017 | J19 | 04/2019 | ult_preco | 79.301,660 |
| 02/01/2017 | J19 | 04/2019 | ajuste | 112,620 |
| 02/01/2017 | J19 | 04/2019 | var_pontos | 0,000 |
| 02/01/2017 | J19 | 04/2019 | ult_of_compra | 0,000 |
| 02/01/2017 | J19 | 04/2019 | ult_of_venda | 74.943,830 |
| 02/01/2017 | N19 | 07/2019 | ajuste_ant | 77.133,610 |
| 02/01/2017 | N19 | 07/2019 | ajuste_corrig | 77.313,440 |
Reparamos que o data frame no slide anterior não está “Tidy”, ou seja não está de forma que cada linha represente um evento e cada coluna represente um atributo do evento.
Para nós, neste caso, um evento é formado por todas as informações de um ativo em um dia e não uma só das informações de um ativo em um dia.
Isso porque é extremamente comum fazermos contas com mais de uma informação do ativo em um dia (máxima - mínima, por exemplo)
O pacote Tidyr ajuda a arrumar os data frames dessas formas. O hex sticker dele é bem explicativo.
pivot_longer() e pivot_wider()Os nomes das principais funções mudaram em setembro de 2019 (quando saiu a versão 1.0.0). Antes se chamavam gather() e spread() e agora se chamam pivot_wider() e pivot_longer(), o que é mais intuitivo.
O nosso data frame tem cada tipo de cotação em cada linha e gostaríamos que essas linhas fossem transformadas em colunas.
A função que faz isso se chama pivot_wider()
Seus parâmetros mais usados são:
data, que é o data frame a ser tratado
names_from, que é o atributo de onde vêm os nomes para os novos atributos
values_from, o atributo de onde vêm os valores dos novos atributos
## Classes 'tbl_df', 'tbl' and 'data.frame': 26549 obs. of 17 variables:
## $ data_out : Date, format: "2017-01-01" "2017-01-02" ...
## $ name : int 1 2 2 2 2 2 2 2 2 2 ...
## $ dia_inutil : logi TRUE NA NA NA NA NA ...
## $ nome_ativo : chr NA "F17" "G17" "H17" ...
## $ vencimento : Date, format: NA "2017-01-01" ...
## $ NA : num NA NA NA NA NA NA NA NA NA NA ...
## $ ajuste_ant : num NA 100000 98918 98058 97059 ...
## $ ajuste_corrig: num NA 100050.7 13.3 98107.1 12.9 ...
## $ preco_abert : num NA 0 13.3 13.2 12.9 ...
## $ preco_min : num NA 0 13.3 13.2 12.9 ...
## $ preco_max : num NA 0 13.3 13.2 12.9 ...
## $ preco_med : num NA 0 13.3 13.2 12.9 ...
## $ ult_preco : num NA 0 98918.1 13.2 97010.1 ...
## $ ajuste : num NA 1.00e+05 2.00e-02 9.81e+04 3.77 ...
## $ var_pontos : num NA 0.02 13.27 1.08 12.9 ...
## $ ult_of_compra: num NA 0 13.3 13.2 12.9 ...
## $ ult_of_venda : num NA 0 97013.9 13.2 95282.7 ...
É muito comum recebermos os dados com colunas que deviam ser valores de um atributo, e não um atributo em si.
O exemplo clássico é a colocação de datas nas colunas do dado, como nos dados retirados do site Datasus
read_csv2(
"dados/siab/cadastro_numero_familias.csv",
skip = 3,
locale = locale(encoding = "latin1" )
) %>%
glimpse()## Observations: 5,502
## Variables: 19
## $ Município <chr> "110001 Alta Floresta D'Oeste", "110037 Alto Alegre ...
## $ `1998` <chr> "2", "1224", "-", "3797", "676", "-", "-", "-", "529...
## $ `1999` <chr> "3458", "2204", "546", "2763", "9922", "2268", "-", ...
## $ `2000` <chr> "4668", "1911", "2002", "2832", "11790", "2615", "17...
## $ `2001` <chr> "5078", "1994", "2348", "3924", "11648", "3061", "18...
## $ `2002` <chr> "5078", "1976", "2348", "3907", "11654", "3732", "18...
## $ `2003` <chr> "5077", "1804", "2021", "3463", "9931", "5499", "138...
## $ `2004` <chr> "4925", "1766", "932", "4077", "18830", "7580", "180...
## $ `2005` <chr> "5865", "1698", "1956", "4141", "14531", "7470", "18...
## $ `2006` <chr> "6518", "3623", "1994", "4244", "16509", "6459", "19...
## $ `2007` <chr> "6489", "3500", "2922", "1642", "17094", "7502", "19...
## $ `2008` <chr> "7093", "3682", "3195", "4493", "16936", "7712", "23...
## $ `2009` <chr> "6946", "3172", "3210", "4693", "16948", "7546", "23...
## $ `2010` <chr> "6836", "3292", "1480", "1586", "16528", "7112", "25...
## $ `2011` <chr> "6918", "3416", "2551", "3122", "16912", "7378", "18...
## $ `2012` <chr> "6699", "3448", "3175", "4162", "18109", "7385", "19...
## $ `2013` <chr> "6336", "3617", "3029", "4242", "19270", "9730", "19...
## $ `2014` <chr> "6201", "3343", "3438", "4242", "14661", "9084", "19...
## $ `2015` <chr> "6181", "3280", "-", "-", "6307", "-", "-", "-", "19...
Acontece que “2009” não é um atributo, mas sim o valor de um atributo que deveria ser data
A função pivot_longe() faz a operação de que precisamos.
data, que é o data frame a ser tratado
names_from, que é o atributo de onde vêm os nomes para os novos atributos
values_from, o atributo de onde vêm os valores dos novos atributos
Note também a função separate(), que divide colunas de acordo com caracteres separadores.
siab_familias <- read_csv2(
"dados/siab/cadastro_numero_familias.csv",
skip = 3,
locale = locale(encoding = "latin1" )
) %>%
pivot_longer(
cols = -`Município`,
names_to = "data",
values_to = "familias"
) %>%
rename(
municipio = `Município`
) %>%
separate(
col = municipio,
into = c("cod_municipio", "municipio"),
sep = " ",
extra = "merge"
) %>%
mutate(
cod_municipio = as.integer(cod_municipio),
data = as.integer(data),
familias = as.integer(familias)
)
head(siab_familias)## # A tibble: 6 x 4
## cod_municipio municipio data familias
## <int> <chr> <int> <int>
## 1 110001 Alta Floresta D'Oeste 1998 2
## 2 110001 Alta Floresta D'Oeste 1999 3458
## 3 110001 Alta Floresta D'Oeste 2000 4668
## 4 110001 Alta Floresta D'Oeste 2001 5078
## 5 110001 Alta Floresta D'Oeste 2002 5078
## 6 110001 Alta Floresta D'Oeste 2003 5077
Para pegar mais informações dos municipios, vamos ler um arquivo baixado do iBGE
municipios <- read_excel("dados/ibge/populacao.xlsx", skip = 2, col_names = TRUE)
head(municipios, n = 30)## # A tibble: 30 x 4
## Cód. Município Ano `Tabela 6579 - População residente ~
## <chr> <chr> <chr> <dbl>
## 1 1100015 Alta Floresta D'Oest~ 2001 26919
## 2 <NA> <NA> 2002 27237
## 3 <NA> <NA> 2003 27563
## 4 <NA> <NA> 2004 29001
## 5 <NA> <NA> 2005 28629
## 6 <NA> <NA> 2006 29005
## 7 <NA> <NA> 2008 24577
## 8 <NA> <NA> 2009 24354
## 9 <NA> <NA> 2011 24228
## 10 <NA> <NA> 2012 24069
## # ... with 20 more rows
Ops… células mescladas
Não deixe o ódio tomar você…
municipios_ajeitado <- municipios %>%
rename(
cod_municipio = 1,
nome_municipio = 2,
ano = 3,
populacao = 4
) %>%
fill(cod_municipio, .direction = "down") %>%
fill(nome_municipio, .direction = "down") %>%
mutate(UF = str_extract(nome_municipio,"\\([A-Z]{2}\\)")) %>%
mutate(UF = str_extract(UF,"[A-Z]{2}")) %>%
mutate(
cod_municipio = as.integer(cod_municipio),
ano = as.integer(ano)
)
head(municipios_ajeitado)## # A tibble: 6 x 5
## cod_municipio nome_municipio ano populacao UF
## <int> <chr> <int> <dbl> <chr>
## 1 1100015 Alta Floresta D'Oeste (RO) 2001 26919 RO
## 2 1100015 Alta Floresta D'Oeste (RO) 2002 27237 RO
## 3 1100015 Alta Floresta D'Oeste (RO) 2003 27563 RO
## 4 1100015 Alta Floresta D'Oeste (RO) 2004 29001 RO
## 5 1100015 Alta Floresta D'Oeste (RO) 2005 28629 RO
## 6 1100015 Alta Floresta D'Oeste (RO) 2006 29005 RO
Para juntar as informações de dois tibbles em um só, podemos fazer isso de três formas
Fonte: (RStudio 2019b)
Anteriormente, pegamos informações do cadastro de famílias…
## # A tibble: 6 x 4
## cod_municipio municipio data familias
## <int> <chr> <int> <int>
## 1 110001 Alta Floresta D'Oeste 1998 2
## 2 110001 Alta Floresta D'Oeste 1999 3458
## 3 110001 Alta Floresta D'Oeste 2000 4668
## 4 110001 Alta Floresta D'Oeste 2001 5078
## 5 110001 Alta Floresta D'Oeste 2002 5078
## 6 110001 Alta Floresta D'Oeste 2003 5077
E de municípios
## # A tibble: 6 x 5
## cod_municipio nome_municipio ano populacao UF
## <int> <chr> <int> <dbl> <chr>
## 1 1100015 Alta Floresta D'Oeste (RO) 2001 26919 RO
## 2 1100015 Alta Floresta D'Oeste (RO) 2002 27237 RO
## 3 1100015 Alta Floresta D'Oeste (RO) 2003 27563 RO
## 4 1100015 Alta Floresta D'Oeste (RO) 2004 29001 RO
## 5 1100015 Alta Floresta D'Oeste (RO) 2005 28629 RO
## 6 1100015 Alta Floresta D'Oeste (RO) 2006 29005 RO
Os códigos são diferentes, mas
de_para_codigos <- read_csv2(
"http://blog.mds.gov.br/redesuas/wp-content/uploads/2018/06/Lista_Munic%C3%ADpios_com_IBGE_Brasil_Versao_CSV.csv",
locale = locale(encoding = "latin1")
) %>%
select(IBGE, IBGE7)
head(de_para_codigos)## # A tibble: 6 x 2
## IBGE IBGE7
## <dbl> <dbl>
## 1 110001 1100015
## 2 110002 1100023
## 3 110003 1100031
## 4 110004 1100049
## 5 110005 1100056
## 6 110006 1100064
Agora juntamos as informações do Siab com as informações dos municípios
siab_familias %>%
inner_join(de_para_codigos, by = c("cod_municipio" = "IBGE")) %>%
inner_join(municipios_ajeitado, by = c("IBGE7" = "cod_municipio", "data" = "ano") ) %>%
View()
head(siab_familias)## # A tibble: 6 x 4
## cod_municipio municipio data familias
## <int> <chr> <int> <int>
## 1 110001 Alta Floresta D'Oeste 1998 2
## 2 110001 Alta Floresta D'Oeste 1999 3458
## 3 110001 Alta Floresta D'Oeste 2000 4668
## 4 110001 Alta Floresta D'Oeste 2001 5078
## 5 110001 Alta Floresta D'Oeste 2002 5078
## 6 110001 Alta Floresta D'Oeste 2003 5077
Seria legal saber qual o tamanho médio das famílias
Fonte: (Exame 2018)
Às vezes mesmo sem querer (será?)
PS. gráfico de 2014
Fonte: (Alves 2014)
Gráfico com sombra, 3D, estilos que dificultam a interpretação
Fonte: (Healy 2018)
O pessoal que usa Excel muitas vezes ama 3D, mas…
(Healy 2018)
Fonte: (White 2015)
Assim como os restaurantes devemos servir pizzas de dois sabores no máximo
Tentem descobrir qual a menor e a menor categoria em cada caso
Fonte: (Viz 2018)
Fonte: (Viz 2018)
Gráficos de dois eixos podem mostrar relações espúrias muito facilmente. E elas dependem da escolha da escala e dos limites dos eixos.
Fonte (Rost 2018)
O mesmo dado pode levar aos seguintes gráficos (e suas soluções)
Enfatize o dado relevante
Integre texto e gráfico
Use fontes e cores diferentes do padrão
Principalmente em colunas e barras, faça o eixo começar de ZERO
loadfonts(device = "win")
by_country <- organdata %>% group_by(consent_law, country) %>%
summarize_if(is.numeric, list(mean = mean, sd = sd), na.rm = TRUE) %>%
ungroup()
p <- ggplot(data = by_country,
mapping = aes(x = gdp_mean, y = health_mean))
p + geom_point( color = "coral4") +
geom_text_repel(data = subset(by_country, gdp_mean > 25000),
mapping = aes(label = country),
size = 3,
color = "coral4",
family="Bookman Old Style"
) +
labs(y = "Gastos com saúde per cap.", x = "PIB per cap." ) +
scale_x_continuous(
labels = number_format(decimal.mark = ",", big.mark = "."),
limits = c(0,NA)
) +
scale_y_continuous(
labels = number_format(decimal.mark = ",", big.mark = "."),
limits = c(0,NA)
) +
theme_minimal(
) +
ggtitle(
label = "Gastos em saúde x PIB"
) +
theme(
text=element_text(family="Bookman Old Style", color = "coral4"),
axis.text = element_text(colour = "coral4"),
panel.background = element_rect(fill = "beige"),
panel.grid.minor = element_line(colour = "bisque1"),
panel.grid.major = element_line(colour = "bisque3")
)Use small multiples: divida o gráfico em gráficos iguais menores cada um com parte dos dados, seguindo uma regra categórica
#("azure2", "chocolate", "steelblue4", "darkslategray", "slategray3", "slategray4")
p <- ggplot(data = gapminder, mapping = aes(x = year, y = gdpPercap))
p + geom_line(color="chocolate", aes(group = country)) +
geom_smooth(size = 1.1, method = "loess", se = FALSE, color = "tan4") +
scale_y_log10(labels=scales::dollar) +
facet_wrap(~ continent, ncol = 5) +
labs(x = "Year",
y = "GDP per capita",
title = "GDP per capita on Five Continents")+
theme_minimal() +
theme(
text=element_text(family="CMU Serif", color = "darkslategray", size = 8),
axis.text = element_text(colour = "darkslategray"),
panel.background = element_rect(fill = "azure2"),
panel.grid.minor = element_line(colour = "slategray2"),
panel.grid.major = element_line(colour = "slategray2"),
strip.text = element_text(family="CMU Serif", colour = "darkslategray"),
aspect.ratio = 1
)GGPLOT2 é a biblioteca de visualização de dados moderna mais usada no R.
Muitos dos problemas listados anteriormente são tratados por ela. É até difícil causar alguns dos problemas anteriores, por exemplo as distorções. É preciso muito malabarismo para produzir um gráfico com 2 eixos.
Por outro lado, a biblioteca facilita muito a criação de small multiples, a criação de gráficos personalizados e complexos
GGPLOT é baseada na filosofia de Tufte (Tufte 1973) e Wilkinson (Wilkinson 1999), em que os gráficos são construídos a partir de dois princípios:
Um gráfico é uma construção em camadas
Os dados ganham sentido a partir de mapeamentos a escalas, que são mapeadas a geometrias
A GGPLOT2 parece mais complicada de usar do que funções como a plot() da biblioteca base do R.
Talvez porque as pessoas não são sempre apresentadas às camadas da gramática “Grammar of Graphics” que fundamenta a biblioteca.
Fonte: (Scavetta 2018)
Dados (data)
Aesthetics (aes()): mapeamento das colunas dos dados a escalas
Geometries geoms_(): elementos visuais que mostram os dados nas escalas
Facets: small multiples
Statistics: representações do dados transformadas por operações matemáticas
Coordinates
Themes: “non-data ink”, ou seja, os elementos que não são diretamente plotados pela existência de dados
Fonte: (Scavetta 2018)
Usando as camadas, vamos montando o gráfico
Vamos usar para este exemplo um dataset clássico, de espécimes de flores: iris
## Observations: 150
## Variables: 5
## $ Sepal.Length <dbl> 5.1, 4.9, 4.7, 4.6, 5.0, 5.4, 4.6, 5.0, 4.4, 4.9,...
## $ Sepal.Width <dbl> 3.5, 3.0, 3.2, 3.1, 3.6, 3.9, 3.4, 3.4, 2.9, 3.1,...
## $ Petal.Length <dbl> 1.4, 1.4, 1.3, 1.5, 1.4, 1.7, 1.4, 1.5, 1.4, 1.5,...
## $ Petal.Width <dbl> 0.2, 0.2, 0.2, 0.2, 0.2, 0.4, 0.3, 0.2, 0.2, 0.1,...
## $ Species <fct> setosa, setosa, setosa, setosa, setosa, setosa, s...
Veja que, pela variável ser representada de forma discreta (uma casa decimal), há sobreposição de pontos. para dar a real impressão de quantos pontos existem, o ideal é inserir um ruído.
ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width)) +
geom_jitter(alpha = 0.6) +
facet_grid(. ~ Species)ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width)) +
geom_jitter(alpha = 0.6) +
facet_grid(. ~ Species) +
stat_smooth(method = "lm", se = F, col = "red")ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width)) +
geom_jitter(alpha = 0.6) +
facet_grid(. ~ Species) +
stat_smooth(method = "lm", se = F, col = "red") +
coord_flip()wes <- wes_palette("Royal2", 5, "discrete")
ggplot(iris, aes(x = Sepal.Length, y = Sepal.Width)) +
geom_jitter(alpha = 0.6, color = wes[1]) +
facet_grid(. ~ Species) +
stat_smooth(method = "lm", se = F, col = wes[1]) +
coord_flip() +
theme_minimal() +
theme(
text=element_text(family="Bradley Hand ITC", color = wes[1], size = 16),
axis.text = element_text(colour = wes[1]),
panel.background = element_rect(fill = "white"),
panel.grid.minor = element_line(colour = wes[2]),
panel.grid.major = element_line(colour = wes[3]),
strip.text = element_text(family="Bradley Hand ITC", color = wes[1]),
panel.border = element_rect(colour = wes[4], fill = NA)
)gols <- read_csv("dados/football_events/ginf.csv") %>%
select(fthg, ftag) %>%
pivot_longer(cols = everything(), names_to = "casa_fora", values_to = "gols")
ggplot(gols) +
geom_histogram(
aes(x = gols),
binwidth = 1
) +
scale_x_continuous(breaks = 0:10, minor_breaks = c()) +
theme_minimal()result <- fitdistr( gols$gols , densfun = "Poisson" )
pois <- rpois(length(gols$gols ), lambda = result$estimate ) %>%
enframe(value = "gols") %>%
mutate(tipo = "poisson")
real_simulado <- gols %>%
mutate(tipo = "real" ) %>%
bind_rows(pois)
ggplot() +
geom_histogram(
data = real_simulado,
aes(x = gols, group = tipo, fill = tipo),
binwidth = 1,
show.legend = TRUE,
position = "identity",
alpha = 0.5
) +
scale_x_continuous(breaks = 0:10, minor_breaks = c()) +
geom_vline(aes(xintercept = result$estimate)) +
geom_text(aes(x = result$estimate, y = 7000 ),nudge_x = 0.3, label = number(result$estimate, accuracy = 0.01 )) +
theme_minimal()O gráfico mostrando a função de probablidade acumulada empírica mostra propriedades que o histograma não mostra
ggplot(gols, aes(x = gols)) +
stat_ecdf(geom = "step") +
scale_x_continuous(breaks = 0:10, minor_breaks = c()) +
theme_minimal()Para variáveis contínuas, faz sentido usar o gráfico de densidade
ufc_pesos <- read_csv("dados/ufc/data.csv") %>%
filter(weight_class == "Heavyweight") %>%
select(
R_Height_cms,
B_Height_cms,
Winner
) %>%
transmute(
altura_vencedor = if_else(Winner == "Red", R_Height_cms, B_Height_cms ),
altura_perdedor = if_else(Winner == "Red", B_Height_cms, R_Height_cms )
) %>%
pivot_longer(cols = everything(), names_to = "resultado", values_to = "altura")
ggplot(ufc_pesos) +
geom_density(aes(x = altura)) +
theme_minimal()Mais uma vez a distribuição empírica nos deixa ver mais coisa: os quantis
## Warning: Removed 1 rows containing non-finite values (stat_ecdf).
## Warning: Removed 1 rows containing non-finite values (stat_density).
ggplot(ufc_pesos) +
stat_ecdf(aes(x = altura, color = resultado), geom = "density" ) +
theme_minimal()## Warning: Removed 1 rows containing non-finite values (stat_ecdf).
ufc_pesos <- read_csv("dados/ufc/data.csv") %>%
select(
weight_class,
R_Height_cms,
B_Height_cms,
Winner
) %>%
transmute(
weight_class,
altura_vencedor = if_else(Winner == "Red", R_Height_cms, B_Height_cms ),
altura_perdedor = if_else(Winner == "Red", B_Height_cms, R_Height_cms )
) %>%
pivot_longer(cols = -weight_class, names_to = "resultado", values_to = "altura")
ggplot(ufc_pesos) +
geom_density_ridges(aes(x = altura, y = weight_class ), fill = "lightblue") +
theme_ridges() +
scale_x_continuous(breaks = seq(150,by = 5, to = 220))Legal a ideia, mas não queremos comparar mulheres também
A biblioteca stringrfacilita muio lidar com strings. Por exemplo detectar um pedaço de string em outra
ufc_pesos <- read_csv("dados/ufc/data.csv") %>%
filter(!str_detect(weight_class, "Women")) %>%
select(
weight_class,
R_Height_cms,
B_Height_cms,
Winner
) %>%
transmute(
weight_class,
altura_vencedor = if_else(Winner == "Red", R_Height_cms, B_Height_cms ),
altura_perdedor = if_else(Winner == "Red", B_Height_cms, R_Height_cms )
) %>%
pivot_longer(cols = -weight_class, names_to = "resultado", values_to = "altura")
ggplot(ufc_pesos) +
geom_density_ridges(aes(x = altura, y = weight_class ), fill = "lightblue") +
theme_ridges() +
scale_x_continuous(breaks = seq(150,by = 5, to = 220))Melhorou, mas ainda á estranho. Melhor seria se as classes de peso estivessem em ordem
No R, as variáveis categóricas são chamadas de fatores. Cada valor possível de um fator é representadas internamente com um identificador numérico, e não com a própria string.
Cada valor possível da variável categórica também é chamada de level
Podemos manipular essas representações facilmente com a forcats.
No caso, queremos ordenar nosso fator com a ordem as classes de peso no UFC
A função fct_relevel possibilita a ordenação manual de uma variável factor
ufc_pesos_ordem <- ufc_pesos %>%
mutate(
weight_class = fct_relevel(weight_class,
c(
"Flyweight",
"Bantamweight",
"Featherweight",
"Lightweight",
"Welterweight",
"Middleweight",
"Light Heavyweight",
"Heavyweight",
"Catch Weight",
"Open Weight"
)
)
)
ggplot(ufc_pesos_ordem) +
geom_density_ridges(aes(x = altura, y = weight_class ), fill = "lightblue") +
theme_ridges() +
scale_x_continuous(breaks = seq(150,by = 5, to = 220))Os gráficos do tipo scatter plot
Vamos brincar um pouco com os dados do Banco Mundial
taxa_homicidios <- wb("VC.IHR.PSRC.P5", country = "all", mrv = 10, POSIXct = TRUE ) %>%
select(iso3c, value, date) %>%
group_by(iso3c) %>%
top_n(1, date) %>%
rename(homicidios = value)
gini <- wb("SI.POV.GINI", country = "all", mrv = 10, POSIXct = TRUE ) %>%
select(iso3c, value, date) %>%
group_by(iso3c) %>%
top_n(1, date) %>%
rename(desigualdade = value)
pib_per_capita <- wb("NY.GDP.PCAP.PP.KD", country = "all", mrv = 10, POSIXct = TRUE ) %>%
select(iso3c, value, date) %>%
group_by(iso3c) %>%
top_n(1, date) %>%
rename(riqueza = value)
pib_gini_homi <- taxa_homicidios %>%
inner_join(gini, by = c("iso3c")) %>%
inner_join(pib_per_capita, by = c("iso3c")) %>%
left_join(codelist, by = c("iso3c") ) %>%
select(riqueza, desigualdade, homicidios, continent, region) %>%
pivot_longer(cols = c("riqueza", "desigualdade"), names_to = "tipo_indice", values_to = "indice" ) %>%
mutate(tipo_indice = str_to_title(tipo_indice))ggplot(pib_gini_homi, aes(y = homicidios, x = indice)) +
geom_point(alpha = 0.4) +
facet_wrap(~tipo_indice, scales = "free", ncol = 1) +
geom_smooth() +
theme_minimal() +
labs(x = "", y = "Homicídios por 100 mil") +
scale_x_continuous(labels = number_format(decimal.mark = ",", big.mark = ".")) É possível visualizar os eixos em log na base 10
ggplot(pib_gini_homi, aes(y = homicidios, x = indice)) +
geom_point(alpha = 0.4) +
facet_wrap(~tipo_indice, scales = "free", ncol = 1) +
geom_smooth() +
theme_minimal() +
labs(x = "", y = "Homicídios por 100 mil") +
scale_x_continuous(labels = number_format(decimal.mark = ",", big.mark = ".")) +
scale_y_log10() É possível também usar as cores para olhar uma terceira característica
ggplot(pib_gini_homi, aes(y = homicidios, x = indice)) +
geom_point(alpha = 0.4, aes(color = continent )) +
facet_wrap(~tipo_indice, scales = "free", ncol = 1) +
geom_smooth() +
theme_minimal() +
labs(x = "", y = "Homicídios por 100 mil") +
scale_x_continuous(labels = number_format(decimal.mark = ",", big.mark = ".")) +
scale_y_log10() +
theme(legend.position = "top")A linha de regressão também pode ser estimada para cada grupo. Neste caso vamos usar o método de regressão linear, pois o LOESS original nao funciona nada bem com muito poucos dados (nem a linear, mas…)
ggplot(pib_gini_homi, aes(y = homicidios, x = indice, color = continent)) +
geom_point(alpha = 0.4 ) +
facet_wrap(~tipo_indice, scales = "free", ncol = 1) +
geom_smooth(se = FALSE, method = "lm") +
theme_minimal() +
labs(x = "", y = "Homicídios por 100 mil") +
scale_x_continuous(labels = number_format(decimal.mark = ",", big.mark = ".")) +
scale_y_log10() analise_desigualdade <- pib_gini_homi %>%
filter(tipo_indice == "Desigualdade")
ggplot(analise_desigualdade, aes(y = homicidios, x = indice, color = continent)) +
geom_point(alpha = 0.4) +
facet_wrap(~tipo_indice, ncol = 1) +
geom_smooth(se = FALSE, method = "lm") +
theme_minimal() +
labs(x = "Índice de Gini", y = "Homicídios por 100 mil") +
scale_x_continuous(labels = number_format(decimal.mark = ",", big.mark = ".")) +
scale_y_log10() +
facet_wrap(~continent) +
theme(legend.position = "top")ggplot(analise_desigualdade, aes(y = homicidios, x = indice, color = continent)) +
geom_text(aes(label = iso3c), size = 2) +
facet_wrap(~tipo_indice, ncol = 1) +
geom_smooth(se = FALSE, method = "lm") +
theme_minimal() +
labs(x = "Índice de Gini", y = "Homicídios por 100 mil") +
scale_x_continuous(labels = number_format(decimal.mark = ",", big.mark = ".")) +
scale_y_log10() +
facet_wrap(~continent) +
theme(legend.position = "top")Podemos avaliar três variáveis contínuas usando um gráfico de bolhas
Primeiro vamos colocar em wide as duas variáveis que tínhamos deixado long.
pib_gini_homi_wide <- pib_gini_homi %>%
pivot_wider(names_from = tipo_indice, values_from = indice )
head(pib_gini_homi_wide)## # A tibble: 6 x 6
## # Groups: iso3c [6]
## iso3c homicidios continent region Riqueza Desigualdade
## <chr> <dbl> <chr> <chr> <dbl> <dbl>
## 1 ALB 2.3 Europe Southern Europe 12306. 29
## 2 DZA 1.4 Africa Northern Africa 13886. 27.6
## 3 AGO 4.8 Africa Middle Africa 5725. 42.7
## 4 ARG 5.1 Americas South America 18282. 41.2
## 5 ARM 2.4 Asia Western Asia 9178. 33.6
## 6 AUS 0.8 Oceania Australia and New Zealand 45439. 35.8
A escala de cor usada abaixo, Viridis, oferece a mesma sensação para olorido e preto e branco e é feita para ajudar daltônicos.
O log foi usado aqui para evitar que os valores extremos dificultem a visualização da escala de cores.
ggplot(pib_gini_homi_wide) +
geom_point(aes(color = homicidios, x = Desigualdade , y = Riqueza )) +
scale_color_viridis_c(trans = "log10", direction = -1, option = "inferno") +
theme_minimal()hdi <- read_csv("dados/hdi/atlas.csv") %>%
rename(municipio = `município` ) %>%
select(
ano,
rdpc,
gini,
municipio,
uf
) %>%
filter(ano == 2010)
violencia <- extract_text("dados/atlasviolencia/8099-tabelamunicipiostodossite.pdf", encoding = "UTF-8") %>%
str_split(pattern = fixed("\n")) %>%
unlist() %>%
enframe( value = "linha") %>%
mutate(
UF = str_extract(linha, "[A-Z]{2}") ,
municipio = str_extract(linha, "(?<=[A-Z]{2} ).+?(?=[0-9])"),
numeros = str_extract_all(linha, "(?<= )[0-9 ,.]*")
) %>%
unnest_legacy() %>%
filter(str_length(numeros)>1) %>%
mutate(
numeros = str_trim(numeros),
municipio = str_trim(municipio) %>% str_to_upper()
) %>%
separate(
col = numeros,
into = c("populacao", "homicidios", "ocultos", "taxa_homicidios"),
sep = " "
) %>%
mutate(taxa_homicidios = parse_number(taxa_homicidios, locale = locale(decimal_mark = ",")) )
ufs <- municipios_ajeitado %>%
select(
UF,
cod_municipio
) %>%
mutate(
cod_uf = cod_municipio %/% 100000
) %>%
select(-cod_municipio) %>%
distinct() %>%
filter(!is.na(cod_uf))
hdi %<>% inner_join(ufs, by = c("uf" = "cod_uf"), suffix = c("_old", ""))
hdi_violencia <- hdi %>%
inner_join(violencia, by = c("municipio", "UF") ) %>%
mutate(
regiao = case_when(
uf %/% 10 == 1 ~ "Norte",
uf %/% 10 == 2 ~ "Nordeste",
uf %/% 10 == 3 ~ "Sudeste",
uf %/% 10 == 4 ~ "Sul",
uf %/% 10 == 5 ~ "Centro-Oeste",
TRUE ~ NA_character_
)
)ggplot(hdi_violencia) +
geom_jitter(aes(color = taxa_homicidios, x = gini , y = rdpc ), alpha = 0.2 ) +
scale_color_gradient(low = "blue", high = "red", trans = "log10" ) +
facet_wrap(~regiao) +
theme_minimal()## Warning: Transformation introduced infinite values in discrete y-axis
ufc_data <- read_csv("dados/ufc/data.csv") %>%
select(weight_class, no_of_rounds )
ufc_raw_data <- read_csv2("dados/ufc/raw_total_fight_data.csv") %>%
select(last_round)
ufc_tudo <- bind_cols(ufc_data, ufc_raw_data) %>%
filter(no_of_rounds == 3) %>%
group_by(weight_class) %>%
mutate(n_classe = n()) %>%
group_by(weight_class, last_round) %>%
summarise(n_round = n(), n_classe = mean(n_classe)) %>%
mutate(frac_lutas = n_round/n_classe ) %>%
ungroup() %>%
filter( weight_class %in%
c(
"Flyweight",
"Bantamweight",
"Featherweight",
"Lightweight",
"Welterweight",
"Middleweight",
"Light Heavyweight",
"Heavyweight"
)) %>%
mutate(
weight_class = fct_relevel(weight_class,
c(
"Flyweight",
"Bantamweight",
"Featherweight",
"Lightweight",
"Welterweight",
"Middleweight",
"Light Heavyweight",
"Heavyweight"
)
)
)ggplot(ufc_tudo, aes(x = last_round, y = weight_class)) +
geom_tile(aes(fill = frac_lutas )) +
geom_text(aes(label = percent(frac_lutas)) ) +
scale_fill_gradient(low = "white", high = "darkgreen", labels = percent ) +
theme_minimal() hdi_desc <- read_csv("dados/hdi/desc.csv")
hdi_tudo <- read_csv("dados/hdi/atlas.csv") %>%
mutate(
regiao = case_when(
uf %/% 10 == 1 ~ "N",
uf %/% 10 == 2 ~ "NE",
uf %/% 10 == 3 ~ "SE",
uf %/% 10 == 4 ~ "S",
uf %/% 10 == 5 ~ "CO",
TRUE ~ NA_character_
)
) %>%
select(
espvida,
anos_estudo = e_anosestudo,
gini,
pind,
pren10ricos,
prentrab,
t_banagua,
regiao
)
ggpairs(hdi_tudo) +
theme_minimal()jogos <- read_csv("dados/football_events/ginf.csv") %>%
mutate(
resultado = case_when(
fthg > ftag ~ "Casa",
fthg < ftag ~ "Fora",
TRUE ~ "Empate"
)
) %>%
count(season, country, resultado)
ggplot(jogos) +
geom_col(aes(y = n, fill = resultado, x = as.factor(season)), position = "fill") +
facet_wrap(~country) +
theme_minimal() +
scale_fill_manual(values = wes_palette("Royal2")) +
scale_y_continuous(labels = percent) +
theme(
axis.text.x = element_text(angle = 90),
legend.position = "top",
text = element_text(family = "Rockwell Condensed")
) +
labs(x = "Temporada", y = "% Vitórias", fill = "Resultado")jogos <- read_csv("dados/football_events/ginf.csv") %>%
filter(season != 2017) %>%
select(season, country, Fora = ftag, Casa = fthg) %>%
pivot_longer(cols = c(Fora, Casa), names_to = "Time", values_to = "Gols" ) %>%
group_by(season, country, Time) %>%
summarise(Gols = sum(Gols))
ggplot(jogos) +
geom_col(aes(y = Gols, fill = Time, x = as.factor(season)), position = "stack") +
facet_wrap(~country) +
theme_minimal() +
scale_fill_manual(values = wes_palette("Royal2")) +
theme(
axis.text.x = element_text(angle = 90),
legend.position = "top",
text = element_text(family = "Rockwell Condensed")
) +
labs(x = "Temporada", y = "Gols", fill = "Time")Repare que há muitos países, ou seja, muitas categorias.
Usando a biblioteca forcats e sua função fct_lump conseguimos criar uma categoria de “Outros”
gdps <- wb(indicator = "NY.GDP.MKTP.PP.KD", country = "countries_only")
gdps_tratado <- gdps %>%
mutate(date = as.integer(date) ) %>%
group_by(country) %>%
mutate(ultimo_gdp = last(value, order_by = date)) %>%
ungroup() %>%
mutate(country = fct_lump(country, n = 7, w = ultimo_gdp, other_level = "Outros")) %>%
group_by(country, date) %>%
summarise(value = sum(value),
ultimo_gdp = sum(ultimo_gdp)) %>%
ungroup() %>%
mutate(country = fct_reorder(country, ultimo_gdp ))
ggplot(gdps_tratado ) +
geom_area(aes(x = date, y = value, fill = country), position = "fill") +
theme_minimal() +
scale_fill_brewer(palette = "Accent") +
theme(
axis.text.x = element_text(angle = 90),
legend.position = "top",
text = element_text(family = "CMU Classical Serif")
) +
labs(x = "Ano", y = "PIB PPP", fill = "País")gdps_tratado <- gdps %>%
mutate(date = as.integer(date) ) %>%
group_by(country) %>%
mutate(ultimo_gdp = last(value, order_by = date)) %>%
ungroup() %>%
mutate(country = fct_lump(country, n = 7, w = ultimo_gdp, other_level = "Outros")) %>%
group_by(country, date) %>%
summarise(value = sum(value),
ultimo_gdp = sum(ultimo_gdp)) %>%
ungroup() %>%
mutate(country = fct_reorder(country, ultimo_gdp ))
ggplot(gdps_tratado ) +
geom_area(aes(x = date, y = value, fill = country) ) +
theme_minimal() +
scale_fill_brewer(palette = "Accent") +
theme(
axis.text.x = element_text(angle = 90),
legend.position = "top",
text = element_text(family = "CMU Serif Extra")
) +
labs(x = "Ano", y = "PIB PPP", fill = "País")Aqui cabe uma torta se houver poucas categorias
gdps_tratado <- gdps %>%
mutate(date = as.integer(date)) %>%
filter(date == max(date) ) %>%
mutate(country = fct_lump(country, n = 1, w = value, other_level = "Resto")) %>%
group_by(country) %>%
summarise(PIB = sum(value))
ggplot(gdps_tratado, aes(x = "", y = PIB, fill = country)) +
geom_bar( width = 1, stat = "identity", color = "white") +
coord_polar("y", start = 0) +
scale_fill_brewer(palette = "Accent") +
theme_void()gdps_tratado <- gdps %>%
mutate(date = as.integer(date)) %>%
filter(date == max(date) ) %>%
mutate(country = fct_lump(country, n = 50, w = value, other_level = "Resto")) %>%
group_by(country) %>%
summarise(PIB = sum(value))
ggplot(gdps_tratado, aes( fill = country, area = PIB, label = country)) +
geom_treemap() +
geom_treemap_text(grow = TRUE) +
theme(
legend.position = "none"
)Aqui apresentaremos RUDIMENTOS de Aprendizado Estatístico com o objetivo de desmistificar alguns conceitos e apresentar algumas considerações que nos ajudarão a iniciar um processo deste tipo.
Pesquisando imagens no Google vemos as percepções a respeito de “Machine Learning” e “Statistical Learning”
Temos acesso a um pedaço dos dados existentes, que usamos para nos ajudar a especificar e treinar o nosso modelo.
Com o(s) modelo(s) treinado(s), faremos inferências a respeito de outros dados futuros ou cuja variável dependente ainda desconhecemos.
Nosso modelo pode ser resumido por uma equação:
\[y = f(x) + \epsilon\]
Onde, idealmente, \(E(\epsilon) = 0\), \(\epsilon\) é independente de \(x\) e \(Var(\epsilon) = \sigma^2\) é constante em relação a \(x\).
Ou seja, temos o objetivo de chegar à \(f()\) mais próxima da ideal com a ajuda de nossos modelos, e existem vários tipos deles.
Podemos chamar a nossa estimativa de função ideal de \(\hat{f}(x)\)
Se usarmos o erro quadrático como ffunção de penalização, podemos escrever a expectativa de erro de uma previsão a respeito de \(x_0\) assim:
Primeiro devemos fazer nossa exploração preliminar.
Podemos executar um pequeno tratamento de Features usando a função pivot_longer() de um jeito diferente, só possível na últiam versão
ufc_data <- read_csv("dados/ufc/data.csv")
ufc_raw_data <- read_csv2("dados/ufc/raw_total_fight_data.csv")
ufc_raw_fighter <- read_csv2("dados/ufc/raw_fighter_details.csv")
ufc_raw_pre <- read_csv2("dados/ufc/preprocessed_data.csv")
ufc_cada_lutador <- bind_cols(ufc_data, ufc_raw_data) %>%
pivot_longer(
cols = matches("[BR]_.*"),
names_to = c("lutador",".value") ,
names_sep = "_"
) %>%
mutate(
ganhou = str_sub(Winner,1,1) == lutador
) %>%
mutate(aprov = wins/(wins+losses) )
ggplot(ufc_cada_lutador) +
geom_boxplot(aes(x = ganhou, y = aprov )) +
facet_wrap(~weight_class) +
theme_minimal()ufc_aprend <- bind_cols(ufc_data, ufc_raw_data) %>%
filter(Winner != "Draw") %>%
mutate(
R_aprov = R_wins / (R_wins + R_losses),
B_aprov = B_wins / (B_wins + B_losses),
) %>%
select(
Winner,
weight_class,
B_Weight_lbs,
B_age,
R_Weight_lbs,
R_age,
B_age,
R_aprov,
B_aprov
) %>%
mutate(
winner_color = Winner,
zebra_blue = if_else(Winner == "Blue",1,0),
red_mais_velho = R_age - B_age,
idade_red = R_age
) %>%
filter(
!is.na(idade_red) & !is.na(red_mais_velho) & !is.na(zebra_blue)
)Como exemplo, podemos observar a relação entre a diferença de idade dos lutadores e o vencedor da luta.
Normalmente o lutador vermelho é o favorito. mas podemos ver que quando o lutador vermelho é velho e mais velho que o azul, ele costuma perder.
ggplot(ufc_aprend ) +
geom_jitter(aes( y = red_mais_velho, x = R_age, color = winner_color ), alpha = 0.15) +
scale_color_manual( values =c("Blue" = "blue", "Red" = "red")) +
facet_wrap( ~weight_class ) +
theme_minimal()Podemos tentar uma regressão linear simples para avaliar isso:
\[ zebra = \alpha + \beta_{idade} idade\_vermelho + \beta_{dif} dif\_vermelho\_mais\_velho + \epsilon \]
Podemos perceber que os betas são signifucativos.
##
## Call:
## lm(formula = zebra_blue ~ idade_red + red_mais_velho, data = ufc_aprend)
##
## Residuals:
## Min 1Q Median 3Q Max
## -0.6314 -0.3407 -0.2586 0.5898 0.8888
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 0.051147 0.061605 0.830 0.406
## idade_red 0.009233 0.002089 4.420 1.01e-05 ***
## red_mais_velho 0.010876 0.001651 6.589 4.91e-11 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.4609 on 4865 degrees of freedom
## Multiple R-squared: 0.03404, Adjusted R-squared: 0.03365
## F-statistic: 85.73 on 2 and 4865 DF, p-value: < 2.2e-16
broomA biblioteca broom ajuda a extrair informações de vários tipos de modelo com as mesmas funções.
## # A tibble: 3 x 5
## term estimate std.error statistic p.value
## <chr> <dbl> <dbl> <dbl> <dbl>
## 1 (Intercept) 0.0511 0.0616 0.830 4.06e- 1
## 2 idade_red 0.00923 0.00209 4.42 1.01e- 5
## 3 red_mais_velho 0.0109 0.00165 6.59 4.91e-11
## # A tibble: 6 x 10
## zebra_blue idade_red red_mais_velho .fitted .se.fit .resid .hat .sigma
## <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 0 32 1 0.357 0.00806 -0.357 3.06e-4 0.461
## 2 0 31 -1 0.326 0.00819 -0.326 3.16e-4 0.461
## 3 0 35 -1 0.363 0.0146 -0.363 1.00e-3 0.461
## 4 1 29 3 0.352 0.00839 0.648 3.31e-4 0.461
## 5 1 26 -6 0.226 0.0103 0.774 5.03e-4 0.461
## 6 0 28 -5 0.255 0.00973 -0.255 4.46e-4 0.461
## # ... with 2 more variables: .cooksd <dbl>, .std.resid <dbl>
caretA biblioteca caret também ajuda muito
modelo_aumentado_factor <- modelo_aumentado %>%
mutate(
previsao_zebra_blue = as_factor(round(.fitted)),
zebra_blue = as_factor(zebra_blue)
)
confusionMatrix(modelo_aumentado_factor$previsao_zebra_blue, modelo_aumentado_factor$zebra_blue )## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 3227 1520
## 1 53 68
##
## Accuracy : 0.6769
## 95% CI : (0.6635, 0.69)
## No Information Rate : 0.6738
## P-Value [Acc > NIR] : 0.3293
##
## Kappa : 0.035
##
## Mcnemar's Test P-Value : <2e-16
##
## Sensitivity : 0.98384
## Specificity : 0.04282
## Pos Pred Value : 0.67980
## Neg Pred Value : 0.56198
## Prevalence : 0.67379
## Detection Rate : 0.66290
## Detection Prevalence : 0.97514
## Balanced Accuracy : 0.51333
##
## 'Positive' Class : 0
##
purrred_mais_velho <- seq(
from = min(ufc_aprend$red_mais_velho, na.rm = TRUE),
to = max(ufc_aprend$red_mais_velho, na.rm = TRUE),
length.out = 50
) %>%
enframe(name = "1", value = "red_mais_velho")
idade_red <- seq(
from = min(ufc_aprend$idade_red, na.rm = TRUE),
to = max(ufc_aprend$idade_red, na.rm = TRUE),
length.out = 50
) %>%
enframe(name = "2", value = "idade_red")
weight_classes <- ufc_aprend %>%
select(weight_class) %>%
distinct()
grid_previsao <- red_mais_velho %>%
crossing(idade_red) %>%
crossing(weight_classes)
previsoes <- augment(modelo_lm, newdata = grid_previsao )
#idade_red + red_mais_velho
ggplot(ufc_aprend ) +
geom_jitter(aes( y = red_mais_velho, x = idade_red, color = winner_color ), alpha = 0.3) +
scale_color_manual( values =c("Blue" = "blue", "Red" = "red")) +
facet_wrap( ~weight_class ) +
geom_point(
data = previsoes %>% filter(.fitted > 0.5),
aes(y = red_mais_velho, x = idade_red ),
color = "lightblue",
alpha = 0.1
) +
geom_point(
data = previsoes %>% filter(.fitted < 0.5),
aes(y = red_mais_velho, x = idade_red ),
color = "lightcoral",
alpha = 0.1
) +
theme_minimal()purrrmodelo_ufc_por_classe <- ufc_aprend %>%
group_by(weight_class) %>%
nest_legacy() %>%
mutate(
modelo = map(data, ~lm(zebra_blue ~ idade_red + red_mais_velho, data = .x)),
) %>%
select(-data)
ufc_por_classe <- modelo_ufc_por_classe %>%
mutate(
aumentado = map(modelo, augment)
) %>%
unnest(aumentado)
ufc_por_classe_treinamento <- ufc_por_classe %>%
ungroup() %>%
mutate(
previsao_zebra_blue = as_factor(round(.fitted)),
zebra_blue = as_factor(zebra_blue)
)
confusionMatrix(ufc_por_classe_treinamento$previsao_zebra_blue, ufc_por_classe_treinamento$zebra_blue )## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 3128 1376
## 1 152 212
##
## Accuracy : 0.6861
## 95% CI : (0.6729, 0.6991)
## No Information Rate : 0.6738
## P-Value [Acc > NIR] : 0.03414
##
## Kappa : 0.1088
##
## Mcnemar's Test P-Value : < 2e-16
##
## Sensitivity : 0.9537
## Specificity : 0.1335
## Pos Pred Value : 0.6945
## Neg Pred Value : 0.5824
## Prevalence : 0.6738
## Detection Rate : 0.6426
## Detection Prevalence : 0.9252
## Balanced Accuracy : 0.5436
##
## 'Positive' Class : 0
##
grid_previsao_com_modelo <- grid_previsao %>%
group_by(weight_class) %>%
nest() %>%
inner_join(modelo_ufc_por_classe, by = c("weight_class")) %>%
mutate(previsoes = map2(.x = modelo, .y = data, .f = ~augment(x = .x, newdata = .y) )) %>%
unnest_legacy(previsoes)
ggplot(ufc_aprend ) +
geom_jitter(aes( y = red_mais_velho, x = idade_red, color = winner_color ), alpha = 0.3) +
scale_color_manual( values =c("Blue" = "blue", "Red" = "red")) +
facet_wrap( ~weight_class ) +
geom_point(
data = grid_previsao_com_modelo %>% filter(.fitted > 0.5),
aes(y = red_mais_velho, x = idade_red ),
color = "lightblue",
alpha = 0.1
) +
geom_point(
data = grid_previsao_com_modelo %>% filter(.fitted < 0.5),
aes(y = red_mais_velho, x = idade_red ),
color = "lightcoral",
alpha = 0.1
) +
theme_minimal()set.seed(2512)
ufc_aprend_classes_selec <- ufc_aprend %>%
filter(weight_class %in%
c(
"Flyweight",
"Bantamweight",
"Featherweight",
"Lightweight",
"Welterweight",
"Middleweight",
"Light Heavyweight",
"Heavyweight"
)
)
index_treino <- createDataPartition(
ufc_aprend_classes_selec$zebra_blue,
p = 0.75,
list = FALSE,
times = 1
)
ufc_aprend_treino <- ufc_aprend_classes_selec %>%
filter(row_number() %in% index_treino) %>%
select(
idade_red,
red_mais_velho,
zebra_blue,
weight_class
)
ufc_aprend_teste <- ufc_aprend_classes_selec %>%
filter(!(row_number() %in% index_treino)) %>%
select(
idade_red,
red_mais_velho,
zebra_blue,
weight_class
)
modelo_ufc_por_classe_treino <- ufc_aprend_treino %>%
group_by(weight_class) %>%
nest_legacy() %>%
mutate(
modelo = map(data, ~lm(zebra_blue ~ idade_red + red_mais_velho, data = .x)),
) %>%
select(-data)
resultados_teste_lm <- ufc_aprend_teste %>%
group_by(weight_class) %>%
nest_legacy() %>%
inner_join(modelo_ufc_por_classe_treino, by = c("weight_class") ) %>%
mutate(
previsao = map2(.x = modelo, .y = data, .f = ~predict.lm(.x, .y) )
) %>%
unnest(cols = c("data","previsao")) %>%
ungroup() %>%
mutate(
actual = if_else(zebra_blue == 1, "B", "R"),
predicted = if_else(previsao > 0.5, "B", "R"),
) %>%
mutate(
actual = fct_relevel(actual, "R", "B"),
predicted = fct_relevel(predicted, "R", "B")
) %>%
select(
actual,
predicted
)
confusionMatrix(resultados_teste_lm$predicted, resultados_teste_lm$actual )## Confusion Matrix and Statistics
##
## Reference
## Prediction R B
## R 733 325
## B 31 38
##
## Accuracy : 0.6841
## 95% CI : (0.6561, 0.7112)
## No Information Rate : 0.6779
## P-Value [Acc > NIR] : 0.3405
##
## Kappa : 0.0814
##
## Mcnemar's Test P-Value : <2e-16
##
## Sensitivity : 0.9594
## Specificity : 0.1047
## Pos Pred Value : 0.6928
## Neg Pred Value : 0.5507
## Prevalence : 0.6779
## Detection Rate : 0.6504
## Detection Prevalence : 0.9388
## Balanced Accuracy : 0.5321
##
## 'Positive' Class : R
##
#ALGO ERRADO AO RODAR O MARKDOWN. NÃO SEI
# modelo_ufc_por_classe_treino_gam <- ufc_aprend_treino %>%
# # group_by(weight_class) %>%
# nest(data =c(zebra_blue, idade_red, red_mais_velho ) ) %>%
# mutate(
# modelo = map(data, ~gam(formula = zebra_blue ~ s(idade_red) + s(red_mais_velho), data = .x))
# ) %>%
# select(-data)
#
#
# resultados_teste_gam <- ufc_aprend_teste %>%
# group_by(weight_class) %>%
# nest_legacy() %>%
# inner_join(modelo_ufc_por_classe_treino_gam, by = c("weight_class") ) %>%
# mutate(
# previsao = map2(.x = modelo, .y = data, .f = ~predict(.x, .y) )
# ) %>%
# unnest(cols = c("data","previsao")) %>%
# ungroup() %>%
# mutate(
# actual = if_else(zebra_blue == 1, "B", "R"),
# predicted = if_else(previsao > 0.5, "B", "R"),
# ) %>%
# mutate(
# actual = fct_relevel(actual, "R", "B"),
# predicted = fct_relevel(predicted, "R", "B")
# ) %>%
# select(
# actual,
# predicted
# )
#
# write_rds(resultados_teste_gam, "dados/ufc/resultados_teste_gam.rds")
resultados_teste_gam <- read_rds("dados/ufc/resultados_teste_gam.rds")
confusionMatrix(resultados_teste_gam$predicted, resultados_teste_gam$actual )## Confusion Matrix and Statistics
##
## Reference
## Prediction R B
## R 716 310
## B 48 53
##
## Accuracy : 0.6823
## 95% CI : (0.6543, 0.7095)
## No Information Rate : 0.6779
## P-Value [Acc > NIR] : 0.3884
##
## Kappa : 0.1026
##
## Mcnemar's Test P-Value : <2e-16
##
## Sensitivity : 0.9372
## Specificity : 0.1460
## Pos Pred Value : 0.6979
## Neg Pred Value : 0.5248
## Prevalence : 0.6779
## Detection Rate : 0.6353
## Detection Prevalence : 0.9104
## Balanced Accuracy : 0.5416
##
## 'Positive' Class : R
##
Plotando as regiões deste modelo mais complexo
#
# grid_previsao_com_modelo_gam <- grid_previsao %>%
# group_by(weight_class) %>%
# nest() %>%
# inner_join(modelo_ufc_por_classe_treino_gam, by = c("weight_class")) %>%
# mutate(previsoes = map2(.x = modelo, .y = data, .f = ~predict( .x, .y) )) %>%
# select(-modelo) %>%
# unnest(cols = c("previsoes","data")) %>%
# ungroup()
#
#
# write_rds(grid_previsao_com_modelo_gam, "dados/ufc/grid_previsao_com_modelo_gam.RDS")
grid_previsao_com_modelo_gam <- read_rds("dados/ufc/grid_previsao_com_modelo_gam.RDS")
ggplot( bind_rows(ufc_aprend_classes_selec) ) +
geom_jitter(aes( y = red_mais_velho, x = idade_red, color = winner_color ), alpha = 0.3) +
scale_color_manual( values =c("Blue" = "blue", "Red" = "red")) +
facet_wrap( ~weight_class ) +
geom_point(
data = grid_previsao_com_modelo_gam %>% filter(previsoes > 0.5),
aes(y = red_mais_velho, x = idade_red ),
color = "lightblue",
alpha = 0.1
) +
geom_point(
data = grid_previsao_com_modelo_gam %>% filter(previsoes < 0.5),
aes(y = red_mais_velho, x = idade_red ),
color = "lightcoral",
alpha = 0.1
) +
theme_minimal()Alves, Cintia. 2014. “Globo News Manipula Gráficos Contra Taxa de Desemprego Brasileira.” 2014. https://jornalggn.com.br/humor/globo-news-manipula-graficos-contra-taxa-de-desemprego-brasileira/.
Boddy, Jessica. 2016. “One in Five Genetics Papers Contains Errors Thanks to Microsoft Excel.” 2016. https://www.sciencemag.org/news/2016/08/one-five-genetics-papers-contains-errors-thanks-microsoft-excel.
Courtiol, Alexandre. 2019. “Data Transformation with Dplyr.” 2019. https://github.com/courtiol/Rguides.
Exame, Revista. 2018. “Post Do Psdb Sobre João Doria Recebe Críticas Em Redes Sociais E é Apagado.” 2018. https://exame.abril.com.br/marketing/joao-doria-subestima-publico-e-retira-postagem-sobre-eleicoes-do-ar/.
Frigaard, Martin. 2017. “Getting Started with Tidyverse in R.” 2017. http://www.storybench.org/getting-started-with-tidyverse-in-r/.
Healy, Kieran. 2018. Data Visualization: A Practical Introduction. Princeton University Press.
QLD, Mazars. 2016. “Tips and Tricks for Optimising Excel.” 2016. https://www.slideshare.net/hanrickcurran/tips-and-tricks-for-optimising-excel.
Rost, Lisa. 2018. “Why Not to Use Two Axes, and What to Use Instead.” 2018. https://blog.datawrapper.de/dualaxis/.
RStudio. 2019a. “Data Import::CHEAT Sheet.” 2019. https://rstudio.com/resources/cheatsheets/.
———. 2019b. “Data Transformation with Dplyr::CHEAT Sheet.” 2019. https://rstudio.com/resources/cheatsheets/.
Scavetta, Rick. 2018. DataCamp: Data Visualization with Ggplot2. Data Camp.
Tufte, Edward. 1973. “The Visual Display of Quantitative Information.” Cheshire: Graphic Press.–2001.–213 p.
Viz, Data to. 2018. “The Issue with Pie Chart.” 2018. https://www.data-to-viz.com/caveat/pie.html.
White, Nicole. 2015. “Blog.” 2015. https://nicolerosewhite.wordpress.com.
Wickham, Hadley. 2019. Advanced R. Chapman; Hall/CRC.
Wickham, Hadley, and Garrett Grolemund. 2016. R for Data Science: Import, Tidy, Transform, Visualize, and Model Data. " O’Reilly Media, Inc.".
Wilkinson, Leland. 1999. The Grammar of Graphics. Springer.